1037 lines
27 KiB
Racket
1037 lines
27 KiB
Racket
|
|
(load-relative "loadtest.rktl")
|
|
|
|
(define shorter? #t)
|
|
|
|
; These message boxes mustn't survive
|
|
(let ([c (make-custodian)])
|
|
(parameterize ([current-custodian c])
|
|
(parameterize ([current-eventspace (make-eventspace)])
|
|
(queue-callback
|
|
(lambda ()
|
|
(queue-callback
|
|
(lambda ()
|
|
(sleep/yield 0.1)
|
|
(queue-callback
|
|
(lambda ()
|
|
(custodian-shutdown-all c)))
|
|
(message-box "w" "q")))
|
|
(message-box "x" "y"))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Windowing Tests ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-syntax FAILS (lambda (stx) (syntax (void))))
|
|
|
|
(define (pause)
|
|
(let ([s (make-semaphore)])
|
|
(flush-display)
|
|
(thread (lambda () (sleep 0.01) (semaphore-post s)))
|
|
(test s 'yield (yield s))))
|
|
|
|
(let ([s (make-semaphore 1)])
|
|
(test s 'yield-wrapped (yield s)))
|
|
(let ([s (make-semaphore 1)])
|
|
(test (list s) 'yield-wrapped (yield (wrap-evt s (lambda (v) (list v))))))
|
|
(let ([s (make-semaphore)])
|
|
(thread (lambda () (sleep 0.01) (semaphore-post s)))
|
|
(test (list s) 'yield-wrapped (yield (wrap-evt s (lambda (v) (list v))))))
|
|
|
|
(define (enable-tests f)
|
|
(printf "Enable ~a~n" f)
|
|
(st #t f is-enabled?)
|
|
(stv f enable #f)
|
|
(st #f f is-enabled?)
|
|
(stv f enable #t)
|
|
(st #t f is-enabled?))
|
|
|
|
(define (drop-file-tests f)
|
|
(printf "Drop File ~a~n" f)
|
|
(st #f f accept-drop-files)
|
|
(stv f accept-drop-files #t)
|
|
(st #t f accept-drop-files)
|
|
(stv f accept-drop-files #f)
|
|
(st #f f accept-drop-files))
|
|
|
|
(define (client->screen-tests f)
|
|
(printf "Client<->Screen ~a~n" f)
|
|
(let-values ([(x y) (send f client->screen 0 0)])
|
|
(stvals '(0 0) f screen->client x y))
|
|
(let-values ([(x y) (send f screen->client 0 0)])
|
|
(stvals '(0 0) f client->screen x y))
|
|
(let-values ([(cw ch) (send f get-client-size)]
|
|
[(w h) (send f get-size)])
|
|
(test #t `(client-size ,f ,cw ,ch ,w ,h) (and (<= 1 cw w) (<= 1 ch h))))
|
|
(stv f refresh))
|
|
|
|
(define (area-tests f sw? sh? no-stretch?)
|
|
(printf "Area ~a~n" f)
|
|
(let ([x (send f min-width)]
|
|
[y (send f min-height)])
|
|
(st sw? f stretchable-width)
|
|
(st sh? f stretchable-height)
|
|
(stv (send f get-top-level-window) reflow-container)
|
|
(pause) ; to make sure size has taken effect
|
|
(let-values ([(w h) (if no-stretch?
|
|
(send f get-size)
|
|
(values 0 0))])
|
|
(printf "Size ~a x ~a~n" w h)
|
|
(when no-stretch?
|
|
(stv f min-width w) ; when we turn of stretchability, don't resize
|
|
(stv f min-height h))
|
|
(stv f stretchable-width #f)
|
|
(stv f stretchable-height #f)
|
|
(st #f f stretchable-width)
|
|
(st #f f stretchable-height)
|
|
(stv f stretchable-width #t)
|
|
(stv f stretchable-height #t)
|
|
(st #t f stretchable-width)
|
|
(st #t f stretchable-height)
|
|
(stv f stretchable-width sw?)
|
|
(stv f stretchable-height sh?))
|
|
(stv f min-width x)
|
|
(stv f min-height y)))
|
|
|
|
(define (containee-tests f sw? sh? m)
|
|
(area-tests f sw? sh? #f)
|
|
(printf "Containee ~a~n" f)
|
|
(st m f horiz-margin)
|
|
(st m f vert-margin)
|
|
(stv f horiz-margin 3)
|
|
(st 3 f horiz-margin)
|
|
(st m f vert-margin)
|
|
(stv f horiz-margin m)
|
|
(stv f vert-margin 3)
|
|
(st m f horiz-margin)
|
|
(st 3 f vert-margin)
|
|
(stv f vert-margin m))
|
|
|
|
(define (container-tests f win?)
|
|
(printf "Container ~a~n" f)
|
|
(let-values ([(x y) (send f get-alignment)])
|
|
(stv f set-alignment 'right 'bottom)
|
|
(stvals '(right bottom) f get-alignment)
|
|
(stv f set-alignment x y)))
|
|
|
|
(define (cursor-tests f)
|
|
(printf "Cursor ~a~n" f)
|
|
(let ([c (send f get-cursor)])
|
|
(stv f set-cursor c)
|
|
(st c f get-cursor)
|
|
(begin-busy-cursor)
|
|
(end-busy-cursor)
|
|
(st c f get-cursor)
|
|
(stv f set-cursor #f)
|
|
(st #f f get-cursor)
|
|
(begin-busy-cursor)
|
|
(end-busy-cursor)
|
|
(st #f f get-cursor)
|
|
(stv f set-cursor c)))
|
|
|
|
(define (show-tests f)
|
|
(unless (is-a? f dialog%)
|
|
(printf "Show ~a~n" f)
|
|
(let ([on? (send f is-shown?)])
|
|
(stv f show #f)
|
|
(when on?
|
|
(stv f show #t)))))
|
|
|
|
(define (window-tests f sw? sh? parent top m)
|
|
(st parent f get-parent)
|
|
(st top f get-top-level-window)
|
|
(enable-tests f)
|
|
(drop-file-tests f)
|
|
(client->screen-tests f)
|
|
(cursor-tests f)
|
|
(show-tests f))
|
|
|
|
(define (containee-window-tests f sw? sh? parent top m)
|
|
(window-tests f sw? sh? parent top m)
|
|
(containee-tests f sw? sh? m))
|
|
|
|
(define (test-control-event e types)
|
|
(test #t 'event-instance (is-a? e control-event%))
|
|
(test #t 'event-type (pair? (memq (send e get-event-type) types))))
|
|
|
|
(define (label-test b l)
|
|
(let ([&-l (format "&~a" l)]
|
|
[my-l (format "My ~a" l)]
|
|
[&-my-l (format "&My ~a" l)])
|
|
(st &-l b get-label)
|
|
(st l b get-plain-label)
|
|
(stv b set-label &-my-l)
|
|
(st &-my-l b get-label)
|
|
(st my-l b get-plain-label)
|
|
(stv b set-label &-l)))
|
|
|
|
(let ([f (make-object frame% "Yes & No" #f 150 151 20 21)])
|
|
(let ([init-tests
|
|
(lambda (hidden?)
|
|
(st "Yes & No" f get-label)
|
|
(st "Yes No" f get-plain-label)
|
|
(stv f set-label "Yeah & Nay")
|
|
(st "Yeah & Nay" f get-label)
|
|
(st "Yeah Nay" f get-plain-label)
|
|
(stv f set-label "Yes & No")
|
|
(st #f f get-parent)
|
|
(st f f get-top-level-window)
|
|
(case (system-type 'os)
|
|
[(unix)
|
|
(st 21 f get-x)
|
|
(if hidden?
|
|
(st 43 f get-y)
|
|
(st 22 f get-y))]
|
|
[else
|
|
(st 20 f get-x)
|
|
(st 21 f get-y)])
|
|
(st 150 f get-width)
|
|
(st 151 f get-height)
|
|
(stvals (list (send f get-width) (send f get-height)) f get-size)
|
|
(st #f f has-status-line?)
|
|
(st #f f is-iconized?)
|
|
(st #f f get-menu-bar))]
|
|
[space-tests
|
|
(lambda ()
|
|
(printf "Spacing~n")
|
|
(let ([b (send f border)])
|
|
(stv f border 25)
|
|
(st 25 f border)
|
|
(stv f border b))
|
|
(let ([s (send f spacing)])
|
|
(stv f spacing 7)
|
|
(st 7 f spacing)
|
|
(stv f spacing s)))]
|
|
[enable-tests
|
|
(lambda () (enable-tests f))]
|
|
[drop-file-tests
|
|
(lambda ()
|
|
(drop-file-tests f))]
|
|
[client->screen-tests
|
|
(lambda ()
|
|
(printf "Client<->Screen~n")
|
|
(let-values ([(x y) (send f client->screen 0 0)])
|
|
(stvals '(0 0) f screen->client x y))
|
|
(let-values ([(x y) (send f screen->client 0 0)])
|
|
(stvals '(0 0) f client->screen x y)))]
|
|
[container-tests
|
|
(lambda ()
|
|
(printf "Container~n")
|
|
(area-tests f #t #t #t)
|
|
(let-values ([(x y) (send f container-size null)])
|
|
(st x f min-width)
|
|
(st y f min-height))
|
|
(container-tests f #t))]
|
|
[cursor-tests
|
|
(lambda ()
|
|
(test #t 'get-cursor-kind (is-a? (send f get-cursor) cursor%))
|
|
(cursor-tests f))])
|
|
|
|
(st (current-eventspace) f get-eventspace)
|
|
(st #t f can-close?)
|
|
(st #t f can-exit?)
|
|
(stv f focus)
|
|
|
|
(space-tests)
|
|
(enable-tests)
|
|
(client->screen-tests)
|
|
(container-tests)
|
|
(cursor-tests)
|
|
|
|
(printf "Init~n")
|
|
(init-tests #f)
|
|
(stv f show #t)
|
|
(pause)
|
|
(printf "Show Init~n")
|
|
(init-tests #t)
|
|
(stv f show #f)
|
|
(pause)
|
|
(printf "Hide Init~n")
|
|
(init-tests #f)
|
|
(send f show #t)
|
|
(pause)
|
|
|
|
(space-tests)
|
|
(enable-tests)
|
|
(client->screen-tests)
|
|
(container-tests)
|
|
|
|
(stv f change-children values)
|
|
|
|
(printf "Iconize~n")
|
|
(stv f iconize #t)
|
|
(pause)
|
|
(pause)
|
|
(st #t f is-iconized?) ; NB: test will fail on MacOS
|
|
(stv f show #t)
|
|
(pause)
|
|
(st #f f is-iconized?)
|
|
|
|
(stv f maximize #t)
|
|
(pause)
|
|
(stv f maximize #f)
|
|
(pause)
|
|
|
|
(printf "Move~n")
|
|
(stv f move 34 37)
|
|
(pause)
|
|
(FAILS (st 34 f get-x))
|
|
(FAILS (st 37 f get-y))
|
|
(st 150 f get-width)
|
|
(st 151 f get-height)
|
|
|
|
(printf "Resize~n")
|
|
(stv f resize 56 57)
|
|
(pause)
|
|
(FAILS (st 34 f get-x))
|
|
(FAILS (st 37 f get-y))
|
|
(st 56 f get-width)
|
|
(st 57 f get-height)
|
|
|
|
(stv f center)
|
|
(pause)
|
|
(st 56 f get-width)
|
|
(st 57 f get-height)
|
|
|
|
(client->screen-tests)
|
|
|
|
(stv f create-status-line)
|
|
(stv f set-status-text "Hello")
|
|
|
|
(stv f change-children values)
|
|
(st null f get-children)
|
|
(stvals '(center top) f get-alignment)
|
|
|
|
(stv f focus)
|
|
|
|
(cursor-tests)
|
|
|
|
(printf "Menu Bar~n")
|
|
(let ([mb (make-object menu-bar% f)])
|
|
(st mb f get-menu-bar)
|
|
(st f mb get-frame)
|
|
(st null f get-children)
|
|
|
|
(st #t mb is-enabled?)
|
|
(stv mb enable #f)
|
|
(st #f mb is-enabled?)
|
|
(stv mb enable #t)
|
|
(st #t mb is-enabled?)
|
|
|
|
(st null mb get-items)
|
|
|
|
(printf "Menu 1~n")
|
|
(let* ([m (make-object menu% "&File" mb)]
|
|
[i m]
|
|
[delete-enable-test (lambda (i parent empty)
|
|
(printf "Item~n")
|
|
(st #f i is-deleted?)
|
|
(st #t i is-enabled?)
|
|
|
|
(stv i delete)
|
|
(st #t i is-deleted?)
|
|
(st empty parent get-items)
|
|
(stv i restore)
|
|
(st #f i is-deleted?)
|
|
|
|
(stv i enable #f)
|
|
(st #f i is-enabled?)
|
|
(stv i enable #t)
|
|
(st #t i is-enabled?)
|
|
|
|
(stv i delete)
|
|
(st #t i is-enabled?)
|
|
(stv i enable #f)
|
|
(st #f i is-enabled?)
|
|
(stv i restore)
|
|
(st #f i is-deleted?)
|
|
(st #f i is-enabled?)
|
|
(stv i enable #t)
|
|
|
|
(let ([l (send i get-help-string)])
|
|
(stv i set-help-string "Yikes")
|
|
(st "Yikes" i get-help-string)
|
|
(stv i set-help-string #f)
|
|
(st #f i get-help-string)
|
|
(stv i set-help-string l))
|
|
|
|
(let ([l (send i get-label)])
|
|
(stv i set-label "Matthew")
|
|
(st "Matthew" i get-label)
|
|
(stv i set-label l)))]
|
|
[hit #f])
|
|
(st (list i) mb get-items)
|
|
(st mb i get-parent)
|
|
|
|
(st "&File" i get-label)
|
|
(st "File" i get-plain-label)
|
|
(st #f i get-help-string)
|
|
|
|
(delete-enable-test i mb null)
|
|
|
|
(st null m get-items)
|
|
|
|
(printf "Menu Items~n")
|
|
(let ([i1 (make-object menu-item% "&Plain" m
|
|
(lambda (i e)
|
|
(test-control-event e '(menu))
|
|
(test hit 'expected-plain-menu i)
|
|
(set! hit 'plain)
|
|
'oops)
|
|
#f "Help")]
|
|
[i2 (make-object separator-menu-item% m)]
|
|
[i3 (make-object checkable-menu-item% "Che&ckable" m
|
|
(lambda (i e)
|
|
(test-control-event e '(menu))
|
|
(test hit 'expected-check-menu i)
|
|
(set! hit 'check)
|
|
'oops)
|
|
#\C)]
|
|
[shortcut-test
|
|
(lambda (i empty name)
|
|
(delete-enable-test i m empty)
|
|
|
|
(printf "Shortcut~n")
|
|
(set! hit i)
|
|
(stv i command (make-object control-event% 'menu))
|
|
(test name 'hit-command hit)
|
|
|
|
(let ([c (send i get-shortcut)])
|
|
(stv i set-shortcut #\M)
|
|
(st #\M i get-shortcut)
|
|
(stv i set-shortcut #f)
|
|
(st #f i get-shortcut)
|
|
(stv i set-shortcut c))
|
|
|
|
(st (get-default-shortcut-prefix) i get-shortcut-prefix)
|
|
(let ([p (send i get-shortcut-prefix)])
|
|
(stv i set-shortcut-prefix '(shift))
|
|
(st '(shift) i get-shortcut-prefix)
|
|
(stv i set-shortcut-prefix '(ctl))
|
|
(st '(ctl) i get-shortcut-prefix)
|
|
(stv i set-shortcut-prefix '(shift ctl))
|
|
(st '(shift ctl) i get-shortcut-prefix)
|
|
(stv i set-shortcut-prefix p)))])
|
|
(st (list i1 i2 i3) m get-items)
|
|
|
|
(st "&Plain" i1 get-label)
|
|
(st "Plain" i1 get-plain-label)
|
|
(st "Help" i1 get-help-string)
|
|
(st #f i1 get-shortcut)
|
|
|
|
(st "Che&ckable" i3 get-label)
|
|
(st "Checkable" i3 get-plain-label)
|
|
(st #f i3 get-help-string)
|
|
(st #\C i3 get-shortcut)
|
|
|
|
(shortcut-test i1 (list i2 i3) 'plain)
|
|
(shortcut-test i3 (list i2 i1) 'check)
|
|
|
|
(st (list i2 i1 i3) m get-items)
|
|
(stv i2 delete)
|
|
(st #t i2 is-deleted?)
|
|
(st (list i1 i3) m get-items)
|
|
(stv i2 restore)
|
|
(st #f i2 is-deleted?)
|
|
(st (list i1 i3 i2) m get-items)
|
|
|
|
'done)
|
|
|
|
(printf "Menu 2~n")
|
|
(let* ([m2 (make-object menu% "&Edit" mb "Help Edit")]
|
|
[i2 m2])
|
|
(st (list i i2) mb get-items)
|
|
(st mb i2 get-parent)
|
|
|
|
(st "&Edit" i2 get-label)
|
|
(st "Edit" i2 get-plain-label)
|
|
(st "Help Edit" i2 get-help-string)
|
|
|
|
(delete-enable-test i2 mb (list i))
|
|
|
|
(st null m2 get-items)
|
|
|
|
; Move orig to end
|
|
(stv i delete)
|
|
(stv i restore)
|
|
(st (list i2 i) mb get-items)))
|
|
|
|
'done)))
|
|
|
|
(define frame (let ([l (get-top-level-windows)])
|
|
(test 1 'list-size (length l))
|
|
(car l)))
|
|
(st "Yes & No" frame get-label)
|
|
|
|
(send frame show #f)
|
|
|
|
(define (test-controls parent frame)
|
|
(define side-effect #f)
|
|
|
|
(printf "Buttons~n")
|
|
(letrec ([b (make-object button%
|
|
"&Button"
|
|
parent
|
|
(lambda (bt e)
|
|
(test bt 'same-button b)
|
|
(test-control-event e '(button))
|
|
(set! side-effect 'button)
|
|
'oops)
|
|
'(border))])
|
|
(label-test b "Button")
|
|
(stv b command (make-object control-event% 'button))
|
|
(test 'button 'button-callback side-effect)
|
|
|
|
(containee-window-tests b #f #f parent frame 2))
|
|
|
|
(printf "Check Box~n")
|
|
(letrec ([c (make-object check-box%
|
|
"&Check Box"
|
|
parent
|
|
(lambda (cb e)
|
|
(test cb 'same-check c)
|
|
(test-control-event e '(check-box))
|
|
(set! side-effect 'check-box)
|
|
'oops)
|
|
null)])
|
|
(label-test c "Check Box")
|
|
(stv c command (make-object control-event% 'check-box))
|
|
(test 'check-box 'check-box-callback side-effect)
|
|
|
|
(st #f c get-value)
|
|
(stv c set-value #t)
|
|
(st #t c get-value)
|
|
(stv c set-value #f)
|
|
(st #f c get-value)
|
|
|
|
(containee-window-tests c #f #f parent frame 2))
|
|
(let ([c (make-object check-box% "True"
|
|
parent void
|
|
null
|
|
#t)])
|
|
(st #t c get-value))
|
|
|
|
(printf "Radio Box~n")
|
|
(letrec ([r (make-object radio-box%
|
|
"&Radio Box"
|
|
(list "O&ne" "T&wo" "T&hree")
|
|
parent
|
|
(lambda (rb e)
|
|
(test rb 'same-radio r)
|
|
(test-control-event e '(radio-box))
|
|
(set! side-effect 'radio-box)
|
|
'oops)
|
|
'(vertical))])
|
|
(label-test r "Radio Box")
|
|
(stv r command (make-object control-event% 'radio-box))
|
|
(test 'radio-box 'radio-box-callback side-effect)
|
|
|
|
; Try every combination of enable states:
|
|
(let ([try-all
|
|
(lambda ()
|
|
(let loop ([n 7])
|
|
(let ([0? (positive? (bitwise-and n 1))]
|
|
[1? (positive? (bitwise-and n 2))]
|
|
[2? (positive? (bitwise-and n 4))])
|
|
(st 0? r is-enabled? 0)
|
|
(st 1? r is-enabled? 1)
|
|
(st 2? r is-enabled? 2)
|
|
(let ([0? (positive? (bitwise-and (sub1 n) 1))]
|
|
[1? (positive? (bitwise-and (sub1 n) 2))]
|
|
[2? (positive? (bitwise-and (sub1 n) 4))])
|
|
(stv r enable 0 0?)
|
|
(stv r enable 1 1?)
|
|
(stv r enable 2 2?)
|
|
(unless (zero? n)
|
|
(loop (sub1 n))))))
|
|
(st #t r is-enabled? 0)
|
|
(st #t r is-enabled? 1)
|
|
(st #t r is-enabled? 2))])
|
|
(try-all)
|
|
(stv r enable #f)
|
|
(try-all)
|
|
(stv r enable #t))
|
|
|
|
(st "O&ne" r get-item-label 0)
|
|
(st "T&wo" r get-item-label 1)
|
|
(st "T&hree" r get-item-label 2)
|
|
(st "One" r get-item-plain-label 0)
|
|
(st "Two" r get-item-plain-label 1)
|
|
(st "Three" r get-item-plain-label 2)
|
|
|
|
(st 3 r get-number)
|
|
|
|
(st 0 r get-selection)
|
|
(stv r set-selection 1)
|
|
(st 1 r get-selection)
|
|
(stv r set-selection 2)
|
|
(st 2 r get-selection)
|
|
(stv r set-selection 1)
|
|
(st 1 r get-selection)
|
|
(stv r set-selection 0)
|
|
(st 0 r get-selection)
|
|
|
|
(containee-window-tests r #f #f parent frame 2))
|
|
(letrec ([r (make-object radio-box%"Radio Two"
|
|
(list "O&ne" "T&wo" "T&hree")
|
|
parent
|
|
void
|
|
'(vertical)
|
|
2)])
|
|
(st 2 r get-selection))
|
|
(mismatch (make-object radio-box%"Radio Two"
|
|
(list "O&ne" "T&wo" "T&hree")
|
|
parent
|
|
void
|
|
'(vertical)
|
|
3))
|
|
|
|
(printf "Gauge~n")
|
|
(letrec ([g (make-object gauge%
|
|
"&Gauge"
|
|
10
|
|
parent
|
|
'(horizontal))])
|
|
(label-test g "Gauge")
|
|
|
|
(st 0 g get-value)
|
|
(stv g set-value 8)
|
|
(st 8 g get-value)
|
|
(stv g set-value 0)
|
|
(st 0 g get-value)
|
|
(stv g set-value 10)
|
|
(st 10 g get-value)
|
|
|
|
(st 10 g get-range)
|
|
(stv g set-range 11)
|
|
(st 11 g get-range)
|
|
(st 10 g get-value)
|
|
(stv g set-range 8)
|
|
(st 8 g get-range)
|
|
(st 8 g get-value)
|
|
(stv g set-range 1)
|
|
(st 1 g get-range)
|
|
(st 1 g get-value)
|
|
(stv g set-range 10)
|
|
(st 10 g get-range)
|
|
(st 1 g get-value)
|
|
|
|
(containee-window-tests g #t #f parent frame 2))
|
|
|
|
(printf "Slider~n")
|
|
(letrec ([s (make-object slider%
|
|
"&Slider"
|
|
-2 8
|
|
parent
|
|
(lambda (sl e)
|
|
(test sl 'same-slider s)
|
|
(test-control-event e '(slider))
|
|
(set! side-effect 'slider)
|
|
'oops)
|
|
3
|
|
'(horizontal))])
|
|
(label-test s "Slider")
|
|
(stv s command (make-object control-event% 'slider))
|
|
(test 'slider 'slider-callback side-effect)
|
|
|
|
(st 3 s get-value)
|
|
(stv s set-value 4)
|
|
(st 4 s get-value)
|
|
(stv s set-value -2)
|
|
(st -2 s get-value)
|
|
(stv s set-value 8)
|
|
(st 8 s get-value)
|
|
|
|
(containee-window-tests s #t #f parent frame 2))
|
|
|
|
(let ([test-list-control
|
|
(lambda (l choice? multi?)
|
|
(st 3 l get-number)
|
|
|
|
(st "A" l get-string 0)
|
|
(st "B" l get-string 1)
|
|
(st "C & D" l get-string 2)
|
|
|
|
(unless choice?
|
|
(st 'a l get-data 0)
|
|
(st #f l get-data 1)
|
|
(st 'c-&-d l get-data 2))
|
|
|
|
(st 0 l find-string "A")
|
|
(st 1 l find-string "B")
|
|
(st 2 l find-string "C & D")
|
|
(st #f l find-string "C")
|
|
|
|
(stv l set-selection 2)
|
|
(st 2 l get-selection)
|
|
(st "C & D" l get-string-selection)
|
|
(stv l set-selection 1)
|
|
(st 1 l get-selection)
|
|
(st "B" l get-string-selection)
|
|
(stv l set-selection 0)
|
|
(st 0 l get-selection)
|
|
(st "A" l get-string-selection)
|
|
|
|
(stv l set-string-selection "C & D")
|
|
(st 2 l get-selection)
|
|
(st "C & D" l get-string-selection)
|
|
(stv l set-string-selection "B")
|
|
(st 1 l get-selection)
|
|
(st "B" l get-string-selection)
|
|
(stv l set-string-selection "A")
|
|
(st 0 l get-selection)
|
|
(st "A" l get-string-selection)
|
|
|
|
(stv l set-selection 2)
|
|
|
|
(unless choice?
|
|
(st '(2) l get-selections)
|
|
(stv l set-selection 1)
|
|
(st #t l is-selected? 1)
|
|
(st #f l is-selected? 2)
|
|
(st '(1) l get-selections)
|
|
(stv l set-selection 2)
|
|
(st #f l is-selected? 1)
|
|
(st #t l is-selected? 2)
|
|
|
|
(stv l select 2 #f)
|
|
(st '() l get-selections)
|
|
(st #f l get-selection)
|
|
(stv l select 0 #t)
|
|
(st '(0) l get-selections)
|
|
|
|
(stv l select 2 #t)
|
|
(st (if multi? '(0 2) '(2)) l get-selections)
|
|
(stv l select 1 #t)
|
|
(st (if multi? '(0 1 2) '(1)) l get-selections)
|
|
(stv l select 1 #f)
|
|
(st (if multi? '(0 2) '()) l get-selections)
|
|
(st (if multi? 0 #f) l get-selection)
|
|
(stv l select 2 #t)
|
|
(st (if multi? '(0 2) '(2)) l get-selections)
|
|
(st (if multi? 0 2) l get-selection)
|
|
(st multi? l is-selected? 0)
|
|
(st #t l is-selected? 2)
|
|
(stv l set-selection 2)
|
|
(st '(2) l get-selections))
|
|
|
|
(if choice?
|
|
(stv l append "E")
|
|
(stv l append "E" 'e))
|
|
(st 4 l get-number)
|
|
(st 2 l get-selection)
|
|
(unless choice?
|
|
(st 'e l get-data 3))
|
|
(stv l append "F & G")
|
|
(st 5 l get-number)
|
|
(st 2 l get-selection)
|
|
(unless choice?
|
|
(st #f l get-data 4))
|
|
|
|
(stv l set-selection 4)
|
|
(st 4 l get-selection)
|
|
(st "F & G" l get-string-selection)
|
|
(stv l set-selection 2)
|
|
(stv l set-string-selection "F & G")
|
|
(st 4 l get-selection)
|
|
(st "F & G" l get-string-selection)
|
|
|
|
(unless choice?
|
|
(stv l delete 1)
|
|
(st 4 l get-number)
|
|
(st "A" l get-string 0)
|
|
(st 'a l get-data 0)
|
|
(st "C & D" l get-string 1)
|
|
(st 'c-&-d l get-data 1)
|
|
|
|
(stv l delete 0)
|
|
(st 3 l get-number))
|
|
|
|
(stv l clear)
|
|
(st 0 l get-number)
|
|
(st #f l get-selection)
|
|
(st #f l get-string-selection)
|
|
|
|
(stv l append "Z")
|
|
(st 1 l get-number)
|
|
(when choice?
|
|
(st 0 l get-selection)
|
|
(st "Z" l get-string-selection))
|
|
|
|
(unless choice?
|
|
(st 1 l get-number)
|
|
(stv l set '("ONe" "TW&o" "THRee"))
|
|
(st 3 l get-number)
|
|
(st "ONe" l get-string 0)
|
|
(st "TW&o" l get-string 1)
|
|
(st "THRee" l get-string 2)
|
|
|
|
(stv l set-data 0 'my-example-data)
|
|
(stv l set-data 2 'my-other-data)
|
|
(st 'my-example-data l get-data 0)
|
|
(st #f l get-data 1)
|
|
(st 'my-other-data l get-data 2))
|
|
|
|
'done-list)])
|
|
|
|
(printf "Choice~n")
|
|
(letrec ([c (make-object choice%
|
|
"&Choice"
|
|
'("A" "B" "C & D")
|
|
parent
|
|
(lambda (ch e)
|
|
(test ch 'same-choice c)
|
|
(test-control-event e '(choice))
|
|
(set! side-effect 'choice)
|
|
'oops)
|
|
null)])
|
|
(label-test c "Choice")
|
|
(stv c command (make-object control-event% 'choice))
|
|
(test 'choice 'choice-callback side-effect)
|
|
|
|
(st 0 c get-selection)
|
|
|
|
(test-list-control c #t #f)
|
|
|
|
(containee-window-tests c #f #f parent frame 2))
|
|
(letrec ([c (make-object choice% "Choice 2"
|
|
'("A" "B" "C & D")
|
|
parent void
|
|
null
|
|
2)])
|
|
(st 2 c get-selection))
|
|
(mismatch (make-object choice% "Choice 2"
|
|
'("A" "B" "C & D")
|
|
parent void
|
|
null
|
|
3))
|
|
|
|
(let ([mk-list
|
|
(lambda (style)
|
|
(printf "List Box: ~a~n" style)
|
|
(letrec ([l (make-object list-box%
|
|
"&List Box"
|
|
'("A" "B" "C & D")
|
|
parent
|
|
(lambda (lb e)
|
|
(test lb 'same-list-box l)
|
|
(test-control-event e '(list-box))
|
|
(set! side-effect 'list-box)
|
|
'oops)
|
|
(list style))])
|
|
(label-test l "List Box")
|
|
(stv l command (make-object control-event% 'list-box))
|
|
(test 'list-box 'list-box-callback side-effect)
|
|
|
|
(stv l set-data 0 'a)
|
|
(stv l set-data 2 'c-&-d)
|
|
|
|
(test-list-control l #f (and (memq style '(multiple extended)) #t))
|
|
|
|
(containee-window-tests l #t #t parent frame 2)
|
|
|
|
(stv parent delete-child l)))])
|
|
|
|
(mk-list 'single)
|
|
(mk-list 'multiple)
|
|
(mk-list 'extended))
|
|
|
|
'done-lists)
|
|
(let ([l (make-object list-box% "List Two"
|
|
'("A" "B" "C & D")
|
|
parent
|
|
void
|
|
(list 'single)
|
|
2)])
|
|
(st 2 l get-selection))
|
|
(mismatch (make-object list-box% "List Two"
|
|
'("A" "B" "C & D")
|
|
parent
|
|
void
|
|
(list 'single)
|
|
3))
|
|
|
|
(let loop ([styles '((single) (multiple) (multiple hscroll))])
|
|
(unless (null? styles)
|
|
(let ([t (make-object text-field% "Label" parent void "Starting Value" (car styles))])
|
|
(st "Starting Value" t get-value)
|
|
(stv t set-value "different")
|
|
(st "different" t get-value)
|
|
|
|
(test #t 'is-editor? (is-a? (send t get-editor) text%))
|
|
|
|
(containee-window-tests t #t
|
|
(and (memq 'multiple (car styles)) #t)
|
|
parent frame 2)
|
|
|
|
(send parent delete-child t)
|
|
(loop (cdr styles)))))
|
|
|
|
(let ([c (make-object canvas% parent '(hscroll vscroll))])
|
|
|
|
(printf "Tab Focus~n")
|
|
(st #f c accept-tab-focus)
|
|
(stv c accept-tab-focus #t)
|
|
(st #t c accept-tab-focus)
|
|
(stv c accept-tab-focus #f)
|
|
(st #f c accept-tab-focus)
|
|
|
|
(stv c init-auto-scrollbars 500 606 .02 .033)
|
|
; (stv c set-scrollbars 100 101 5 6 2 3 10 20 #t)
|
|
(let-values ([(w h) (send c get-virtual-size)]
|
|
[(cw ch) (send c get-client-size)])
|
|
(printf "Canvas size: Virtual: ~a x ~a Client: ~a x ~a~n" w h cw ch)
|
|
(let ([check-scroll
|
|
(lambda (xpos ypos)
|
|
(let-values ([(x y) (send c get-view-start)])
|
|
(let ([coerce (lambda (x) (inexact->exact (floor x)))])
|
|
(test (coerce (* xpos (- 500 cw))) `(canvas-view-x ,xpos ,ypos ,x ,cw) x)
|
|
(test (coerce (* ypos (- 606 ch))) `(canvas-view-y ,xpos ,ypos ,y ,ch) y))))])
|
|
(test 500 'canvas-virt-w-size w)
|
|
(test 606 'canvas-virt-h-size h)
|
|
|
|
(check-scroll 0.02 0.033)
|
|
|
|
(st 0 c get-scroll-pos 'horizontal)
|
|
(st 0 c get-scroll-pos 'vertical)
|
|
(st 0 c get-scroll-page 'horizontal)
|
|
(st 0 c get-scroll-page 'vertical)
|
|
(st 0 c get-scroll-range 'horizontal)
|
|
(st 0 c get-scroll-range 'vertical)
|
|
|
|
(stv c scroll 0.1 0.1)
|
|
(check-scroll 0.1 0.1)
|
|
(stv c scroll #f 0.2)
|
|
(check-scroll 0.1 0.2)
|
|
(stv c scroll 0.0 #f)
|
|
(check-scroll 0.0 0.2)
|
|
|
|
'done-sb))
|
|
|
|
(stv c init-manual-scrollbars 5 6 2 3 4 5)
|
|
(let-values ([(w h) (send c get-virtual-size)]
|
|
[(cw ch) (send c get-client-size)])
|
|
(let ([check-scroll
|
|
(lambda (xpos ypos)
|
|
(st xpos c get-scroll-pos 'horizontal)
|
|
(st ypos c get-scroll-pos 'vertical)
|
|
|
|
(test cw 'canvas-virt-w-size w)
|
|
(test ch 'canvas-virt-h-size h)
|
|
|
|
(let-values ([(x y) (send c get-view-start)])
|
|
(test 0 'canvas-view-x x)
|
|
(test 0 'canvas-view-y y)))])
|
|
|
|
(check-scroll 4 5)
|
|
|
|
(st 2 c get-scroll-page 'horizontal)
|
|
(st 3 c get-scroll-page 'vertical)
|
|
(st 5 c get-scroll-range 'horizontal)
|
|
(st 6 c get-scroll-range 'vertical)
|
|
|
|
(stv c scroll 1 1)
|
|
(check-scroll 4 5)
|
|
|
|
(stv c set-scroll-pos 'horizontal 1)
|
|
(check-scroll 1 5)
|
|
(stv c set-scroll-pos 'vertical 0)
|
|
(check-scroll 1 0)
|
|
|
|
(stv c set-scroll-page 'horizontal 1)
|
|
(st 1 c get-scroll-page 'horizontal)
|
|
(st 3 c get-scroll-page 'vertical)
|
|
(stv c set-scroll-page 'vertical 2)
|
|
(st 1 c get-scroll-page 'horizontal)
|
|
(st 2 c get-scroll-page 'vertical)
|
|
|
|
'done-sb))
|
|
|
|
(stv c warp-pointer 21 23)
|
|
|
|
(containee-window-tests c #t #t parent frame 0))
|
|
|
|
(let* ([e (make-object text%)]
|
|
[c (make-object editor-canvas%
|
|
parent e
|
|
null
|
|
102)])
|
|
(let loop ([n 100])
|
|
(unless (zero? n)
|
|
(send e insert (format "line ~a~n" n))
|
|
(loop (sub1 n))))
|
|
|
|
(st #f c allow-scroll-to-last)
|
|
(stv c allow-scroll-to-last #t)
|
|
(st #t c allow-scroll-to-last)
|
|
(stv c allow-scroll-to-last #f)
|
|
|
|
(st 'hello c call-as-primary-owner (lambda () 'hello))
|
|
|
|
(st #f c force-display-focus)
|
|
(stv c force-display-focus #t)
|
|
(st #t c force-display-focus)
|
|
(stv c force-display-focus #f)
|
|
|
|
(st e c get-editor)
|
|
(stv c set-editor #f)
|
|
(st #f c get-editor)
|
|
(stv c set-editor e)
|
|
(st e c get-editor)
|
|
|
|
(st #f c lazy-refresh)
|
|
(stv c lazy-refresh #t)
|
|
(st #t c lazy-refresh)
|
|
(stv c lazy-refresh #f)
|
|
|
|
(st #f c scroll-with-bottom-base)
|
|
(stv c scroll-with-bottom-base #t)
|
|
(st #t c scroll-with-bottom-base)
|
|
(stv c scroll-with-bottom-base #f)
|
|
|
|
(stv c set-line-count 6)
|
|
(stv c set-line-count #f)
|
|
|
|
(containee-window-tests c #t #t parent frame 0))
|
|
|
|
'done)
|
|
|
|
(test-controls frame frame)
|
|
|
|
(define (panel-tests frame% show?)
|
|
(define (panel-test % win?)
|
|
(let* ([frame (make-object frame% "Panel Test" #f 100 100)]
|
|
[panel (if %
|
|
(make-object % frame)
|
|
frame)])
|
|
(let ([go
|
|
(lambda ()
|
|
(test-controls panel frame)
|
|
(if win?
|
|
((if % containee-window-tests window-tests) panel #t #t (and % frame) frame 0)
|
|
(area-tests panel #t #t #f))
|
|
(when (is-a? panel panel%)
|
|
(st #t panel get-orientation (is-a? panel horizontal-panel%)))
|
|
(container-tests panel win?)
|
|
(send frame show #f))])
|
|
(when (eq? show? 'dialog)
|
|
(queue-callback go))
|
|
(when show?
|
|
(send frame show #t))
|
|
(unless (eq? show? 'dialog)
|
|
(go)))))
|
|
(panel-test #f #t)
|
|
(unless shorter?
|
|
(panel-test vertical-pane% #f)
|
|
(panel-test horizontal-pane% #f)
|
|
(panel-test vertical-panel% #t)
|
|
(panel-test horizontal-panel% #t)))
|
|
|
|
(panel-tests dialog% #f)
|
|
(panel-tests frame% #t)
|
|
(panel-tests frame% #f)
|
|
(panel-tests dialog% 'dialog)
|
|
|
|
|
|
(report-errs)
|