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

fix test so that labels can be regexps (as was already

Browse Source 
documented) and tidy up framework/test docs
This commit is contained in:
Robby Findler 2012-11-03 10:19:59 -05:00
parent 0377bda947
commit c375042f10
1 changed files with 14 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/framework/test.rkt
View File

@ -253,22 +253,26 @@
(define object-tag 'test:find-object) (define object-tag 'test:find-object)
;; find-object : class (union string (object -> boolean)) -> object ;; find-object : class (union string regexp (object -> boolean)) -> object
(define (find-object obj-class b-desc) (define (find-object obj-class b-desc)
(λ () (λ ()
(cond (cond
[(or (string? b-desc) [(or (string? b-desc)
(regexp? b-desc)
(procedure? b-desc)) (procedure? b-desc))
(let* ([active-frame (test:get-active-top-level-window)] (let* ([active-frame (test:get-active-top-level-window)]
[_ (unless active-frame [_ (unless active-frame
(error object-tag (error object-tag
"could not find object: ~a, no active frame" "could not find object: ~e, no active frame"
b-desc))] b-desc))]
[child-matches? [child-matches?
(λ (child) (λ (child)
(cond (cond
[(string? b-desc) [(string? b-desc)
(equal? (send child get-label) b-desc)] (equal? (send child get-label) b-desc)]
[(regexp? b-desc)
(and (send child get-label)
(regexp-match? b-desc (send child get-label)))]
[(procedure? b-desc) [(procedure? b-desc)
(b-desc child)]))] (b-desc child)]))]
[found [found
@ -287,13 +291,13 @@
(send panel get-children)))]) (send panel get-children)))])
(or found (or found
(error object-tag (error object-tag
"no object of class ~a named ~e in active frame" "no object of class ~e named ~e in active frame"
obj-class obj-class
b-desc)))] b-desc)))]
[(is-a? b-desc obj-class) b-desc] [(is-a? b-desc obj-class) b-desc]
[else (error [else (error
object-tag object-tag
"expected either a string or an object of class ~a as input, received: ~a" "expected either a string or an object of class ~e as input, received: ~e"
obj-class b-desc)]))) obj-class b-desc)])))
@ -936,7 +940,8 @@
(proc-doc/names (proc-doc/names
test:keystroke test:keystroke
(->* ((or/c char? symbol?)) (->* ((or/c char? symbol?))
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift))) ((listof (or/c 'alt 'control 'meta 'shift
'noalt 'nocontrol 'nometea 'noshift)))
void?) void?)
((key) ((key)
((modifier-list null))) ((modifier-list null)))
@ -973,10 +978,11 @@
(proc-doc/names (proc-doc/names
test:mouse-click test:mouse-click
(->* (->*
((symbols 'left 'middle 'right) ((or/c 'left 'middle 'right)
(and/c exact? integer?) (and/c exact? integer?)
(and/c exact? integer?)) (and/c exact? integer?))
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift))) ((listof (or/c 'alt 'control 'meta 'shift 'noalt
'nocontrol 'nometa 'noshift)))
void?) void?)
((button x y) ((button x y)
((modifiers null))) ((modifiers null)))
@ -985,7 +991,7 @@
@method[canvas<%> on-event] method. @method[canvas<%> on-event] method.
Use @racket[test:button-push] to click on a button. Use @racket[test:button-push] to click on a button.
On the Macintosh, @racket['right] corresponds to holding down the command Under Mac OS X, @racket['right] corresponds to holding down the command
modifier key while clicking and @racket['middle] cannot be generated. modifier key while clicking and @racket['middle] cannot be generated.
Under Windows, @racket['middle] can only be generated if the user has a Under Windows, @racket['middle] can only be generated if the user has a