test.rkt
1 #lang at-exp racket/base 2 3 (require racket/class 4 racket/contract/base 5 racket/gui/base 6 scribble/srcdoc 7 (for-syntax racket/base) 8 (prefix-in :: framework/private/focus-table)) 9 (generate-delayed-documents) ; enables for-doc--for-label import of `framework' 10 (require/doc scheme/base scribble/manual 11 (for-label framework)) 12 13 (define (test:top-level-focus-window-has? pred) 14 (let ([tlw (test:get-active-top-level-window)]) 15 (and tlw 16 (let loop ([tlw tlw]) 17 (or (pred tlw) 18 (and (is-a? tlw area-container<%>) 19 (ormap loop (send tlw get-children)))))))) 20 21 (define initial-run-interval 0) ;; milliseconds 22 23 ;; 24 ;; The minimum time an action is allowed to run before returning from 25 ;; mred:test:action. Controls the rate at which actions are started, 26 ;; and gives some slack time for real events to complete (eg, update). 27 ;; Make-parameter doesn't do what we need across threads. 28 ;; Probably don't need semaphores here (set! is atomic). 29 ;; Units are in milliseconds (as in mred:timer%). 30 ;; 31 32 (define run-interval 33 (let ([tag 'test:run-interval] 34 [msec initial-run-interval]) 35 (case-lambda 36 [() msec] 37 [(x) (if (and (integer? x) (exact? x) (<= 0 x)) 38 (set! msec x) 39 (error tag "expects exact, non-negative integer, given: ~e" x))]))) 40 41 ;; 42 ;; How we get into the handler thread, and put fake actions 43 ;; on the real event queue. 44 ;; 45 46 (define install-timer 47 (λ (msec thunk) 48 (let ([timer (instantiate timer% () 49 [notify-callback (λ () (thunk))])]) 50 (send timer start msec #t)))) 51 52 ;; 53 ;; Simple accounting of actions and errors. 54 ;; 55 ;; Keep number of unfinished actions. An error in the buffer 56 ;; (caught but not-yet-reraised) counts as an unfinished action. 57 ;; (but kept in the-error, not count). 58 ;; 59 ;; Keep buffer of one error, and reraise at first opportunity. 60 ;; Keep just first error, any others are thrown on the floor. 61 ;; Reraising the error flushes the buffer. 62 ;; Store exn in box, so can correctly catch (raise #f). 63 ;; 64 ;; These values are set in handler thread and read in main thread, 65 ;; so certainly need semaphores here. 66 ;; 67 68 (define-values (begin-action end-action end-action-with-error 69 get-exn-box is-exn? num-actions) 70 (let 71 ([sem (make-semaphore 1)] 72 [count 0] ;; number unfinished actions. 73 [the-error #f]) ;; boxed exn struct, or else #f. 74 (letrec 75 ([begin-action 76 (λ () 77 (semaphore-wait sem) 78 (set! count (add1 count)) 79 (semaphore-post sem))] 80 81 [end-action 82 (λ () 83 (semaphore-wait sem) 84 (set! count (sub1 count)) 85 (semaphore-post sem))] 86 87 [end-action-with-error 88 (λ (exn) 89 (semaphore-wait sem) 90 (set! count (sub1 count)) 91 (unless the-error 92 (set! the-error (box exn))) 93 (semaphore-post sem))] 94 95 [get-exn-box 96 (λ () 97 (semaphore-wait sem) 98 (let ([ans the-error]) 99 (set! the-error #f) 100 (semaphore-post sem) 101 ans))] 102 103 [is-exn? 104 (λ () 105 (semaphore-wait sem) 106 (let ([ans (if the-error #t #f)]) 107 (semaphore-post sem) 108 ans))] 109 110 [num-actions 111 (λ () 112 (semaphore-wait sem) 113 (let ([ans (+ count (if the-error 1 0))]) 114 (semaphore-post sem) 115 ans))]) 116 117 (values begin-action end-action end-action-with-error 118 get-exn-box is-exn? num-actions)))) 119 120 ;; Functions to export, always in main thread. 121 122 (define number-pending-actions num-actions) 123 124 (define reraise-error 125 (λ () 126 (let ([exn-box (get-exn-box)]) 127 (if exn-box (raise (unbox exn-box)) (void))))) 128 129 ;; 130 ;; Start running thunk in handler thread. 131 ;; Don't return until run-interval expires, and thunk finishes, 132 ;; raises error, or yields (ie, at event boundary). 133 ;; Reraise error (if exists) even from previous action. 134 ;; Note: never more than one timer (of ours) on real event queue. 135 ;; 136 137 (define run-one 138 (let ([yield-semaphore (make-semaphore 0)] 139 [thread-semaphore (make-semaphore 0)]) 140 (thread 141 (λ () 142 (let loop () 143 (semaphore-wait thread-semaphore) 144 (sleep) 145 (semaphore-post yield-semaphore) 146 (loop)))) 147 (λ (thunk) 148 (let ([sem (make-semaphore 0)]) 149 (letrec ([start 150 (λ () ;; eventspace main thread 151 152 ;; guarantee (probably) that some events are handled 153 (semaphore-post thread-semaphore) 154 (yield yield-semaphore) 155 156 (install-timer (run-interval) return) 157 (unless (is-exn?) 158 (begin-action) 159 (call-with-exception-handler 160 (λ (exn) 161 (end-action-with-error exn) 162 ((error-escape-handler))) 163 thunk) 164 (end-action)))] 165 166 [return (λ () (semaphore-post sem))]) 167 168 (install-timer 0 start) 169 (semaphore-wait sem) 170 (reraise-error)))))) 171 172 (define current-get-eventspaces 173 (make-parameter (λ () (list (current-eventspace))))) 174 175 (define test:use-focus-table (make-parameter #f)) 176 177 (define (test:get-active-top-level-window) 178 (ormap (λ (eventspace) 179 (parameterize ([current-eventspace eventspace]) 180 (cond 181 [(test:use-focus-table) 182 (define lst (::frame:lookup-focus-table)) 183 (define focusd (and (not (null? lst)) (car lst))) 184 (when (eq? (test:use-focus-table) 'debug) 185 (define f2 (get-top-level-focus-window)) 186 (unless (eq? focusd f2) 187 (eprintf "found mismatch focus-table: ~s vs get-top-level-focus-window: ~s\n" 188 (map (λ (x) (send x get-label)) lst) 189 (and f2 (list (send f2 get-label)))))) 190 focusd] 191 [else 192 (get-top-level-focus-window)]))) 193 ((current-get-eventspaces)))) 194 195 (define (get-focused-window) 196 (let ([f (test:get-active-top-level-window)]) 197 (and f 198 (send f get-edit-target-window)))) 199 200 (define time-stamp current-milliseconds) 201 202 ;; 203 ;; Return list of window's ancestors from root down to window 204 ;; (including window). Used for on-subwindow-char and on-subwindow-event. 205 ;; get-parent returns #f for no parent. 206 ;; If stop-at-top-level-window? is #t, then the ancestors up to the 207 ;; first top-level-window are returned. 208 ;; 209 210 (define ancestor-list 211 (λ (window stop-at-top-level-window?) 212 (let loop ([w window] [l null]) 213 (if (or (not w) 214 (and stop-at-top-level-window? 215 (is-a? w top-level-window<%>))) 216 l 217 (loop (send w get-parent) (cons w l)))))) 218 219 ;; 220 ;; Returns #t if window is in active-frame, else #f. 221 ;; get-parent returns () for no parent. 222 ;; 223 224 (define (in-active-frame? window) 225 (let ([frame (test:get-active-top-level-window)]) 226 (let loop ([window window]) 227 (cond [(not window) #f] 228 [(not frame) #f] 229 [(null? window) #f] ;; is this test needed? 230 [(object=? window frame) #t] 231 [else (loop (send window get-parent))])))) 232 233 ;; 234 ;; Verify modifier list. 235 ;; l, valid : lists of symbols. 236 ;; returns first item in l *not* in valid, or else #f. 237 ;; 238 239 (define verify-list 240 (λ (l valid) 241 (cond [(null? l) #f] 242 [(member (car l) valid) (verify-list (cdr l) valid)] 243 [else (car l)]))) 244 245 (define verify-item 246 (λ (item valid) 247 (verify-list (list item) valid))) 248 249 ;;; 250 ;;; find-object obj-class b-desc 251 ;;; returns an object belonging to obj-class, where b-desc 252 ;;; is either an object, or a string 253 ;;; 254 255 (define object-tag 'test:find-object) 256 257 ;; find-object : class (union string regexp (object -> boolean)) -> object 258 (define (find-object obj-class b-desc) 259 (λ () 260 (cond 261 [(or (string? b-desc) 262 (regexp? b-desc) 263 (procedure? b-desc)) 264 (let* ([active-frame (test:get-active-top-level-window)] 265 [_ (unless active-frame 266 (error object-tag 267 "could not find object: ~e, no active frame" 268 b-desc))] 269 [child-matches? 270 (λ (child) 271 (cond 272 [(string? b-desc) 273 (equal? (send child get-label) b-desc)] 274 [(regexp? b-desc) 275 (and (send child get-label) 276 (regexp-match? b-desc (send child get-label)))] 277 [(procedure? b-desc) 278 (b-desc child)]))] 279 [found 280 (let loop ([panel active-frame]) 281 (ormap (λ (child) 282 (cond 283 [(and (is-a? child obj-class) 284 (child-matches? child)) 285 child] 286 [(is-a? child area-container-window<%>) 287 (and (send child is-shown?) 288 (loop child))] 289 [(is-a? child area-container<%>) 290 (loop child)] 291 [else #f])) 292 (send panel get-children)))]) 293 (or found 294 (error object-tag 295 "no object of class ~e named ~e in active frame" 296 obj-class 297 b-desc)))] 298 [(is-a? b-desc obj-class) b-desc] 299 [else (error 300 object-tag 301 "expected either a string or an object of class ~e as input, received: ~e" 302 obj-class b-desc)]))) 303 304 305 ;;; functions specific to various user input 306 307 ;;; CONTROL functions, to be specialized for individual controls 308 309 (define control-action 310 (λ (error-tag event-sym find-ctrl update-control) 311 (run-one 312 (λ () 313 (let ([event (make-object control-event% event-sym)] 314 [ctrl (find-ctrl)]) 315 (cond 316 [(not (send ctrl is-shown?)) 317 (error error-tag "control ~e is not shown (label ~e)" ctrl (send ctrl get-label))] 318 [(not (send ctrl is-enabled?)) 319 (error error-tag "control ~e is not enabled (label ~e)" ctrl (send ctrl get-label))] 320 [(not (in-active-frame? ctrl)) 321 (error error-tag "control ~e is not in active frame (label ~e)" ctrl (send ctrl get-label))] 322 [else 323 (update-control ctrl) 324 (send ctrl command event) 325 (void)])))))) 326 327 ;; 328 ;; BUTTON 329 ;; 330 331 (define (button-push button) 332 (control-action 333 'test:button-push 334 'button 335 (find-object button% button) 336 void)) 337 338 ;; 339 ;; CHECK-BOX 340 ;; 341 342 (define (set-check-box! in-cb state) 343 (control-action 344 'test:set-check-box! 345 'check-box 346 (find-object check-box% in-cb) 347 (λ (cb) (send cb set-value state)))) 348 349 ;; 350 ;; RADIO-BOX 351 ;; 352 353 (define (build-labels radio-box) 354 (string-append 355 (format "~s" (send radio-box get-item-label 0)) 356 (let loop ([n (- (send radio-box get-number) 1)]) 357 (cond 358 [(zero? n) ""] 359 [else (string-append " " 360 (format "~s" 361 (send radio-box get-item-label 362 (- (send radio-box get-number) 363 n))) 364 (loop (- n 1)))])))) 365 366 (define (set-radio-box! in-cb state) 367 (control-action 368 'test:set-radio-box! 369 'radio-box 370 (find-object radio-box% in-cb) 371 (λ (rb) 372 (cond 373 [(string? state) 374 (let ([total (send rb get-number)]) 375 (let loop ([n total]) 376 (cond 377 [(zero? n) (error 'test:set-radio-box! 378 "did not find ~e as a label for ~e; labels: ~a" 379 state in-cb 380 (build-labels rb))] 381 [else (let ([i (- total n)]) 382 (if (ith-item-matches? rb state i) 383 (if (send rb is-enabled? i) 384 (send rb set-selection i) 385 (error 'test:set-radio-box! 386 "label ~e is disabled" 387 state)) 388 (loop (- n 1))))])))] 389 [(number? state) 390 (unless (send rb is-enabled? state) 391 (error 'test:set-radio-box! "item ~a is not enabled\n" state)) 392 (send rb set-selection state)] 393 [else (error 'test:set-radio-box! 394 "expected a string or a number as second arg, got: ~e (other arg: ~e)" 395 state in-cb)])))) 396 397 (define (ith-item-matches? rb state i) 398 (cond 399 [(string? state) 400 (or (string=? state (send rb get-item-label i)) 401 (string=? state (send rb get-item-plain-label i)))] 402 [(regexp? state) 403 (or (regexp-match state (send rb get-item-label i)) 404 (regexp-match state (send rb get-item-plain-label i)))])) 405 406 ;; set-radio-box-item! : string -> void 407 (define (set-radio-box-item! state) 408 (control-action 409 'test:set-check-box-state! 410 'radio-box 411 (find-object radio-box% (entry-matches state)) 412 (λ (rb) 413 (let ([total (send rb get-number)]) 414 (let loop ([n total]) 415 (cond 416 [(zero? n) (error 'test:set-radio-box-item! "internal error")] 417 [else (let ([i (- total n)]) 418 (if (ith-item-matches? rb state i) 419 (if (send rb is-enabled? i) 420 (send rb set-selection i) 421 (error 'test:set-radio-box! 422 "label ~e is disabled" 423 state)) 424 (loop (- n 1))))])))))) 425 426 ;; entry-matches : string | regexp -> radio-box -> boolean 427 (define (entry-matches name) 428 (procedure-rename 429 (λ (rb) 430 (let loop ([n (send rb get-number)]) 431 (cond 432 [(zero? n) #f] 433 [else 434 (let ([itm (send rb get-item-label (- n 1))] 435 [pln-itm (send rb get-item-plain-label (- n 1))]) 436 (or (cond 437 [(string? name) 438 (or (equal? name itm) 439 (equal? name pln-itm))] 440 [(regexp? name) 441 (or (regexp-match name itm) 442 (regexp-match name pln-itm))]) 443 (loop (- n 1))))]))) 444 (string->symbol 445 (if (regexp? name) 446 (object-name name) 447 name)))) 448 449 ;;; CHOICE 450 451 ; set-choice! : ((instance in-choice%) (union string number) -> void) 452 (define (set-choice! in-choice str) 453 (control-action 454 'test:set-choice! 455 'choice 456 (find-object choice% in-choice) 457 (λ (choice) 458 (cond 459 [(number? str) (send choice set-selection str)] 460 [(string? str) (send choice set-string-selection str)] 461 [else (error 'test:set-choice! 462 "expected a string or a number as second arg, got: ~e (other arg: ~e)" 463 str in-choice)])))) 464 465 (define (set-list-box! in-lb str) 466 (control-action 467 'test:set-list-box! 468 'list-box 469 (find-object list-box% in-lb) 470 (λ (lb) 471 (cond 472 [(number? str) (send lb set-selection str)] 473 [(string? str) (send lb set-string-selection str)] 474 [else (error 'test:set-list-box! 475 "expected a string or a number as second arg, got: ~e (other arg: ~e)" 476 str in-lb)])))) 477 478 ;; 479 ;; KEYSTROKES 480 ;; 481 ;; Give ancestors (from root down) option of handling key event 482 ;; with on-subwindow-char. If none want it, then send to focused window 483 ;; with (send <window> on-char <wx:key-event>). 484 ;; 485 ;; key: char or integer. 486 ;; optional modifiers: 'alt, 'control, 'meta, 'shift, 487 ;; 'noalt, 'nocontrol, 'nometa, 'noshift. 488 ;; 489 ;; Window must be shown, in active frame, and either the window has 490 ;; on-char, or else some ancestor must grab key with on-subwindow-char. 491 ;; 492 493 (define key-tag 'test:keystroke) 494 (define legal-keystroke-modifiers 495 (list 'alt 'control 'meta 'shift 496 'noalt 'nocontrol 'nometa 'noshift)) 497 498 (define valid-key-symbols 499 (list 'escape ;; just trying this for the heck of it -- JBC, 2010-08-13 500 'start 'cancel 'clear 'shift 'control 'menu 'pause 'capital 501 'prior 'next 'end 'home 'left 'up 'right 'down 'select 'print 502 'execute 'snapshot 'insert 'help 'numpad0 'numpad1 'numpad2 503 'numpad3 'numpad4 'numpad5 'numpad6 'numpad7 'numpad8 'numpad9 504 'multiply 'add 'separator 'subtract 'decimal 'divide 'f1 'f2 'f3 505 'f4 'f5 'f6 'f7 'f8 'f9 'f10 'f11 'f12 'f13 'f14 'f15 'f16 'f17 506 'f18 'f19 'f20 'f21 'f22 'f23 'f24 'numlock 'scroll)) 507 508 (define keystroke 509 (case-lambda 510 [(key) (keystroke key null)] 511 [(key modifier-list) 512 (cond 513 [(not (or (char? key) (memq key valid-key-symbols))) 514 (error key-tag "expects char or valid key symbol, given: ~e" key)] 515 [(not (list? modifier-list)) 516 (error key-tag "expected a list as second argument, got: ~e" modifier-list)] 517 [(verify-list modifier-list legal-keystroke-modifiers) 518 => (λ (mod) (error key-tag "unknown key modifier: ~e" mod))] 519 [else 520 (run-one 521 (λ () 522 (let ([window (get-focused-window)]) 523 (cond 524 [(not window) 525 (error key-tag "no focused window")] 526 [(not (send window is-shown?)) 527 (error key-tag "focused window is not shown")] 528 [(not (send window is-enabled?)) 529 (error key-tag "focused window is not enabled")] 530 [(not (in-active-frame? window)) 531 (error 532 key-tag 533 (string-append 534 "focused window is not in active frame;" 535 "active frame's label is ~s and focused window is in a frame with label ~s") 536 (let ([f (test:get-active-top-level-window)]) 537 (and f (send (test:get-active-top-level-window) get-label))) 538 (let loop ([p window]) 539 (cond 540 [(is-a? p top-level-window<%>) 541 (send p get-label)] 542 [(is-a? p area<%>) 543 (loop (send p get-parent))] 544 [else #f])))] 545 [else 546 (let ([event (make-key-event key window modifier-list)]) 547 (send-key-event window event) 548 (void))]))))])])) 549 550 ;; delay test for on-char until all ancestors decline on-subwindow-char. 551 (define (send-key-event window event) 552 (let loop ([l (ancestor-list window #t)]) 553 (cond [(null? l) 554 (cond 555 [(method-in-interface? 'on-char (object-interface window)) 556 (send window on-char event)] 557 [(is-a? window text-field%) 558 (send (send window get-editor) on-char event)] 559 [else 560 (error 561 key-tag 562 "focused window is not a text-field% and does not have on-char, ~e" window)])] 563 [else 564 (define ancestor (car l)) 565 (cond 566 [(and (is-a? ancestor window<%>) 567 (send ancestor on-subwindow-char window event)) 568 #f] 569 [else 570 (loop (cdr l))])]))) 571 572 ;; Make full key-event% object. 573 ;; Shift is determined implicitly from key-code. 574 ;; Alt, Meta, Control come from modifier-list. 575 ;; get-alt-down, etc are #f unless explicitly set to #t. 576 ;; WILL WANT TO ADD SET-POSITION WHEN THAT GETS IMPLEMENTED. 577 578 (define make-key-event 579 (λ (key window modifier-list) 580 (let ([event (make-object key-event%)]) 581 (send event set-key-code key) 582 (send event set-time-stamp (time-stamp)) 583 (set-key-modifiers event key modifier-list) 584 event))) 585 586 (define set-key-modifiers 587 (λ (event key modifier-list) 588 (when (shifted? key) (send event set-shift-down #t)) 589 (let loop ([l modifier-list]) 590 (unless (null? l) 591 (let ([mod (car l)]) 592 (cond 593 [(eq? mod 'alt) (send event set-alt-down #t)] 594 [(eq? mod 'control) (send event set-control-down #t)] 595 [(eq? mod 'meta) (send event set-meta-down #t)] 596 [(eq? mod 'shift) (send event set-shift-down #t)] 597 [(eq? mod 'noalt) (send event set-alt-down #f)] 598 [(eq? mod 'nocontrol) (send event set-control-down #f)] 599 [(eq? mod 'nometa) (send event set-meta-down #f)] 600 [(eq? mod 'noshift) (send event set-shift-down #f)] 601 [else (error key-tag "unknown key modifier: ~e" mod)]) 602 (loop (cdr l))))))) 603 604 (define shifted? 605 (let* ([shifted-keys '(#\? #\: #\~ #\\ #\| 606 #\< #\> #\{ #\} #\[ #\] #\( #\) 607 #\! #\@ #\# #\$ #\% #\^ #\& #\* #\_ #\+ 608 #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M 609 #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)]) 610 (λ (key) 611 (memq shifted-keys shifted-keys)))) 612 613 ;; 614 ;; MENU ITEMS 615 ;; 616 ;; Select menu item with: 617 ;; (send <frame> command <menu-item-id>) 618 ;; menu, item: strings 619 ;; 620 ;; DOESN'T HANDLE MENU CHECKBOXES YET. 621 ;; 622 623 (define menu-tag 'test:menu-select) 624 625 (define (menu-select menu-name . item-names) 626 (cond 627 [(not (string? menu-name)) 628 (error menu-tag "expects string, given: ~e" menu-name)] 629 [(not (andmap string? item-names)) 630 (error menu-tag "expects strings, given: ~e" item-names)] 631 [else 632 (run-one 633 (λ () 634 (let* ([frame (test:get-active-top-level-window)] 635 [item (get-menu-item frame (cons menu-name item-names))] 636 [evt (make-object control-event% 'menu)]) 637 (send evt set-time-stamp (current-milliseconds)) 638 (send item command evt))))])) 639 640 (define get-menu-item 641 (λ (frame item-names) 642 (cond 643 [(not frame) 644 (error menu-tag "no active frame")] 645 [(not (method-in-interface? 'get-menu-bar (object-interface frame))) 646 (error menu-tag "active frame does not have menu bar")] 647 [else 648 (let ([menu-bar (send frame get-menu-bar)]) 649 (unless menu-bar 650 (error menu-tag "active frame does not have menu bar")) 651 (send menu-bar on-demand) 652 (let* ([items (send menu-bar get-items)]) 653 (let loop ([all-items-this-level items] 654 [items items] 655 [this-name (car item-names)] 656 [wanted-names (cdr item-names)]) 657 (cond 658 [(null? items) 659 (error 'menu-select 660 "didn't find a menu: ~e, desired list: ~e, all items at this level ~e" 661 this-name 662 item-names 663 (map (λ (x) (and (is-a? x labelled-menu-item<%>) 664 (send x get-plain-label))) 665 all-items-this-level))] 666 [else (let ([i (car items)]) 667 (cond 668 [(not (is-a? i labelled-menu-item<%>)) 669 (loop all-items-this-level 670 (cdr items) 671 this-name 672 wanted-names)] 673 [(string=? this-name (send i get-plain-label)) 674 (cond 675 [(and (null? wanted-names) 676 (not (is-a? i menu-item-container<%>))) 677 i] 678 [(and (not (null? wanted-names)) 679 (is-a? i menu-item-container<%>)) 680 (loop (send i get-items) 681 (send i get-items) 682 (car wanted-names) 683 (cdr wanted-names))] 684 [else 685 (error menu-tag "no menu matching ~e" item-names)])] 686 [else 687 (loop all-items-this-level 688 (cdr items) 689 this-name 690 wanted-names)]))]))))]))) 691 692 693 ;; 694 ;; SIMPLE MOUSE EVENTS 695 ;; 696 ;; Simple left-click mouse in current canvas. 697 ;; Sends 3 mouse-events to canvas: motion, down, up. 698 ;; 699 ;; Give ancestors (from root down) option of handling mouse event 700 ;; with pre-on-event. If none want it, then send to focused window 701 ;; with on-event. 702 ;; 703 ;; NEED TO EXPAND: DRAGGING, DOUBLE-CLICK, MOVING TO OTHER CANVASES, 704 ;; MODIFIER KEYS (SHIFT, META, CONTROL, ALT). 705 ;; 706 707 (define mouse-tag 'test:mouse-action) 708 (define legal-mouse-buttons (list 'left 'middle 'right)) 709 (define legal-mouse-modifiers 710 (list 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift)) 711 712 (define mouse-click 713 (case-lambda 714 [(button x y) (mouse-click button x y null)] 715 [(button x y modifier-list) 716 (cond 717 [(verify-item button legal-mouse-buttons) 718 => (λ (button) 719 (error mouse-tag "unknown mouse button: ~e" button))] 720 [(not (real? x)) 721 (error mouse-tag "expected real, given: ~e" x)] 722 [(not (real? y)) 723 (error mouse-tag "expected real, given: ~e" y)] 724 [(verify-list modifier-list legal-mouse-modifiers) 725 => (λ (mod) 726 (error mouse-tag "unknown mouse modifier: ~e" mod))] 727 [else 728 (run-one 729 (λ () 730 (let ([window (get-focused-window)]) 731 (cond 732 [(not window) 733 (error mouse-tag "no focused window")] 734 [(not (send window is-shown?)) 735 (error mouse-tag "focused window is not shown")] 736 [(not (send window is-enabled?)) 737 (error mouse-tag "focused window is not enabled")] 738 [(not (in-active-frame? window)) 739 (error mouse-tag "focused window is not in active frame")] 740 [else 741 (let ([motion (make-mouse-event 'motion x y modifier-list)] 742 [down (make-mouse-event (list button 'down) x y modifier-list)] 743 [up (make-mouse-event (list button 'up) x y modifier-list)]) 744 (send-mouse-event window motion) 745 (send-mouse-event window down) 746 (send-mouse-event window up) 747 (void))]))))])])) 748 749 750 ;; NEED TO MOVE THE CHECK FOR 'ON-EVENT TO HERE. 751 752 (define send-mouse-event 753 (λ (window event) 754 (let loop ([l (ancestor-list window #t)]) 755 (cond 756 [(null? l) 757 (if (method-in-interface? 'on-event (object-interface window)) 758 (send window on-event event) 759 (error mouse-tag "focused window does not have on-event"))] 760 [(and (is-a? (car l) window<%>) 761 (send (car l) on-subwindow-event window event)) 762 #f] 763 [else (loop (cdr l))])))) 764 765 ;; 766 ;; Make mouse event. 767 ;; 768 769 (define make-mouse-event 770 (λ (type x y modifier-list) 771 (let ([event (make-object mouse-event% (mouse-type-const type))]) 772 (when (and (pair? type) (not (eq? (cadr type) 'up))) 773 (set-mouse-modifiers event (list (car type)))) 774 (set-mouse-modifiers event modifier-list) 775 (send event set-x x) 776 (send event set-y y) 777 (send event set-time-stamp (time-stamp)) 778 event))) 779 780 (define set-mouse-modifiers 781 (λ (event modifier-list) 782 (unless (null? modifier-list) 783 (let ([mod (car modifier-list)]) 784 (cond 785 [(eq? mod 'alt) (send event set-alt-down #t)] 786 [(eq? mod 'control) (send event set-control-down #t)] 787 [(eq? mod 'meta) (send event set-meta-down #t)] 788 [(eq? mod 'shift) (send event set-shift-down #t)] 789 [(eq? mod 'left) (send event set-left-down #t)] 790 [(eq? mod 'middle) (send event set-middle-down #t)] 791 [(eq? mod 'right) (send event set-right-down #t)] 792 [(eq? mod 'noalt) (send event set-alt-down #f)] 793 [(eq? mod 'nocontrol) (send event set-control-down #f)] 794 [(eq? mod 'nometa) (send event set-meta-down #f)] 795 [(eq? mod 'noshift) (send event set-shift-down #f)] 796 [else (error mouse-tag "unknown mouse modifier: ~e" mod)])) 797 (set-mouse-modifiers event (cdr modifier-list))))) 798 799 (define mouse-type-const 800 (λ (type) 801 (cond 802 [(symbol? type) 803 (cond 804 [(eq? type 'motion) 'motion] 805 [(eq? type 'enter) 'enter] 806 [(eq? type 'leave) 'leave] 807 [else (bad-mouse-type type)])] 808 [(and (pair? type) (pair? (cdr type))) 809 (let ([button (car type)] [action (cadr type)]) 810 (cond 811 [(eq? button 'left) 812 (cond 813 [(eq? action 'down) 'left-down] 814 [(eq? action 'up) 'left-up] 815 [(eq? action 'dclick) 'left-dclick] 816 [else (bad-mouse-type type)])] 817 [(eq? button 'middle) 818 (cond 819 [(eq? action 'down) 'middle-down] 820 [(eq? action 'up) 'middle-up] 821 [(eq? action 'dclick) 'middle-dclick] 822 [else (bad-mouse-type type)])] 823 [(eq? button 'right) 824 (cond 825 [(eq? action 'down) 'right-down] 826 [(eq? action 'up) 'right-up] 827 [(eq? action 'dclick) 'right-dclick] 828 [else (bad-mouse-type type)])] 829 [else (bad-mouse-type type)]))] 830 [else (bad-mouse-type type)]))) 831 832 (define bad-mouse-type 833 (λ (type) 834 (error mouse-tag "unknown mouse event type: ~e" type))) 835 836 ;; 837 ;; Move mouse to new window. 838 ;; Implement with three events: 839 ;; leave old window, show top-level frame, enter new window, focus. 840 ;; 841 ;; NEED TO CLEAN UP ACTIONS FOR MOVING TO NEW FRAME. 842 ;; 843 844 (define new-window 845 (let ([tag 'test:new-window]) 846 (λ (new-window) 847 (cond 848 [(not (is-a? new-window window<%>)) 849 (error tag "new-window is not a window<%>")] 850 [else 851 (run-one 852 (λ () 853 (let 854 ([old-window (get-focused-window)] 855 [leave (make-object mouse-event% 'leave)] 856 [enter (make-object mouse-event% 'enter)] 857 [root (for/or ([ancestor (ancestor-list new-window #t)]) 858 (and (is-a? ancestor window<%>) 859 ancestor))]) 860 (send leave set-x 0) (send leave set-y 0) 861 (send enter set-x 0) (send enter set-y 0) 862 863 ;; SOME KLUDGES HERE TO WORK AROUND TEXT% PROBLEMS. 864 865 (when (and old-window (method-in-interface? 'on-event (object-interface old-window))) 866 (send-mouse-event old-window leave)) 867 (send root show #t) 868 (when (method-in-interface? 'on-event (object-interface new-window)) 869 (send-mouse-event new-window enter)) 870 (send new-window focus) 871 (void))))])))) 872 873 (define (close-top-level-window tlw) 874 (when (send tlw can-close?) 875 (send tlw on-close) 876 (send tlw show #f))) 877 878 ;; manual renaming 879 (define test:run-interval run-interval) 880 (define test:number-pending-actions number-pending-actions) 881 (define test:reraise-error reraise-error) 882 (define test:run-one run-one) 883 (define test:current-get-eventspaces current-get-eventspaces) 884 (define test:close-top-level-window close-top-level-window) 885 (define test:button-push button-push) 886 (define test:set-radio-box! set-radio-box!) 887 (define test:set-radio-box-item! set-radio-box-item!) 888 (define test:set-check-box! set-check-box!) 889 (define test:set-choice! set-choice!) 890 (define test:set-list-box! set-list-box!) 891 (define test:keystroke keystroke) 892 (define test:menu-select menu-select) 893 (define test:mouse-click mouse-click) 894 (define test:new-window new-window) 895 896 (define (label-of-enabled/shown-button-in-top-level-window? str) 897 (test:top-level-focus-window-has? 898 (λ (c) 899 (and (is-a? c button%) 900 (string=? (send c get-label) str) 901 (send c is-enabled?) 902 (send c is-shown?))))) 903 904 (define (enabled-shown-button? btn) 905 (and (send btn is-enabled?) 906 (send btn is-shown?))) 907 908 (define (button-in-top-level-focusd-window? btn) 909 (test:top-level-focus-window-has? 910 (λ (c) (eq? c btn)))) 911 912 (provide/doc 913 (proc-doc/names 914 test:button-push 915 (-> (or/c (and/c string? 916 label-of-enabled/shown-button-in-top-level-window?) 917 (and/c (is-a?/c button%) 918 enabled-shown-button? 919 button-in-top-level-focusd-window?)) 920 void?) 921 (button) 922 @{Simulates pushing @racket[button]. If a string is supplied, the 923 primitive searches for a button labelled with that string in the 924 active frame. Otherwise, it pushes the button argument.}) 925 926 (proc-doc/names 927 test:set-radio-box! 928 (-> (or/c string? regexp? (is-a?/c radio-box%)) (or/c string? number?) void?) 929 (radio-box state) 930 @{Sets the radio-box to the label matching @racket[state]. If @racket[state] is a 931 string, this function finds the choice with that label. 932 If it is a regexp, this function finds the first choice whose label matches the regexp. 933 If it is a number, it uses the number as an index into the 934 state. If the number is out of range or if the label isn't 935 in the radio box, an exception is raised. 936 937 If @racket[radio-box] is a string, this function searches for a 938 @racket[radio-box%] object with a label matching that string, 939 otherwise it uses @racket[radio-box] itself.}) 940 941 (proc-doc/names 942 test:set-radio-box-item! 943 (-> (or/c string? regexp?) void?) 944 (entry) 945 @{Finds a @racket[radio-box%] that has a label matching @racket[entry] 946 and sets the radio-box to @racket[entry].}) 947 948 (proc-doc/names 949 test:set-check-box! 950 (-> (or/c string? (is-a?/c check-box%)) boolean? void?) 951 (check-box state) 952 @{Clears the @racket[check-box%] item if @racket[state] is @racket[#f], and sets it 953 otherwise. 954 955 If @racket[check-box] is a string, 956 this function searches for a @racket[check-box%] with a label matching that string, 957 otherwise it uses @racket[check-box] itself.}) 958 959 (proc-doc/names 960 test:set-choice! 961 (-> (or/c string? (is-a?/c choice%)) (or/c string? (and/c number? exact? integer? positive?)) 962 void?) 963 (choice str) 964 @{Selects @racket[choice]'s item @racket[str]. If @racket[choice] is a string, 965 this function searches for a @racket[choice%] with a label matching 966 that string, otherwise it uses @racket[choice] itself.}) 967 968 (proc-doc/names 969 test:set-list-box! 970 (-> (or/c string? (is-a?/c list-box%)) 971 (or/c string? exact-nonnegative-integer?) 972 void?) 973 (choice str/index) 974 @{Selects @racket[list-box]'s item @racket[str]. If @racket[list-box] is a string, 975 this function searches for a @racket[list-box%] with a label matching 976 that string, otherwise it uses @racket[list-box] itself. 977 978 The @racket[str/index] field is used to control which entry in the list 979 box is chosen.}) 980 981 (proc-doc/names 982 test:keystroke 983 (->* ((or/c char? symbol?)) 984 ((listof (or/c 'alt 'control 'meta 'shift 985 'noalt 'nocontrol 'nometa 'noshift))) 986 void?) 987 ((key) 988 ((modifier-list null))) 989 @{This function simulates a user pressing a key. The argument, @racket[key], 990 is just like the argument to the 991 @method[key-event% get-key-code] 992 method of the @racket[key-event%] class. 993 994 @italic{Note:} 995 To send the ``Enter'' key, use @racket[#\return], 996 not @racket[#\newline]. 997 998 The @racket['shift] or @racket['noshift] modifier is implicitly set from @racket[key], 999 but is overridden by the argument list. The @racket['shift] modifier is 1000 set for any capitol alpha-numeric letters and any of the following characters: 1001 @racketblock[ 1002 #\? #\: #\~ #\\ #\| 1003 #\< #\> #\{ #\} #\[ #\] #\( #\) 1004 #\! #\@ #\# #\$ #\% #\^ #\& #\* #\_ #\+ 1005 ] 1006 1007 If conflicting modifiers are provided, the ones later in the list are used.}) 1008 1009 (proc-doc 1010 test:menu-select 1011 (->i ([menu string?]) () #:rest [items (listof string?)] [res void?]) 1012 @{Selects the menu-item named by the @racket[item]s in the menu named @racket[menu]. 1013 1014 @italic{Note:} 1015 The string for the menu item does not include its keyboard equivalent. 1016 For example, to select ``New'' from the ``File'' menu, 1017 use ``New'', not ``New Ctrl+N''.}) 1018 1019 (proc-doc/names 1020 test:mouse-click 1021 (->* 1022 ((or/c 'left 'middle 'right) 1023 (and/c exact? integer?) 1024 (and/c exact? integer?)) 1025 ((listof (or/c 'alt 'control 'meta 'shift 'noalt 1026 'nocontrol 'nometa 'noshift))) 1027 void?) 1028 ((button x y) 1029 ((modifiers null))) 1030 @{Simulates a mouse click at the coordinate (x,y) in the currently 1031 focused @racket[window], assuming that it supports the 1032 @method[canvas<%> on-event] method. 1033 Use @racket[test:button-push] to click on a button. 1034 1035 Under Mac OS, @racket['right] corresponds to holding down the command 1036 modifier key while clicking and @racket['middle] cannot be generated. 1037 1038 Under Windows, @racket['middle] can only be generated if the user has a 1039 three button mouse. 1040 1041 The modifiers later in the list @racket[modifiers] take precedence over 1042 ones that appear earlier.}) 1043 1044 (proc-doc/names 1045 test:run-interval 1046 (case-> 1047 (number? . -> . void?) 1048 (-> number?)) 1049 ((msec) ()) 1050 @{See also @secref{test:actions-completeness}. 1051 The first case in the case-lambda sets 1052 the run interval to @racket[msec] milliseconds and the second 1053 returns the current setting.}) 1054 1055 (parameter-doc 1056 test:current-get-eventspaces 1057 (parameter/c (-> (listof eventspace?))) 1058 func 1059 1060 @{This parameter that specifies which evenspaces 1061 (see also @secref[#:doc '(lib "scribblings/gui/gui.scrbl") "eventspaceinfo"]) 1062 are considered when finding the frontmost frame. 1063 The first case 1064 sets the parameter to @racket[func]. The procedure @racket[func] will be 1065 invoked with no arguments to determine the eventspaces to consider 1066 when finding the frontmost frame for simulated user events. 1067 The second case 1068 returns the current value of the parameter. This will be a procedure 1069 which, when invoked, returns a list of eventspaces.}) 1070 1071 (proc-doc/names 1072 test:new-window 1073 (-> (is-a?/c window<%>) void?) 1074 (window) 1075 @{Moves the keyboard focus to a new window within the currently active 1076 frame. Unfortunately, neither this function nor any other function in 1077 the test engine can cause the focus to move from the top-most (active) frame.}) 1078 1079 (proc-doc/names 1080 test:close-top-level-window 1081 (-> (is-a?/c top-level-window<%>) void?) 1082 (tlw) 1083 @{Use this function to simulate clicking on the close box of a frame. 1084 Closes @racket[tlw] with this expression: 1085 @racketblock[ 1086 (when (send tlw can-close?) 1087 (send tlw on-close) 1088 (send tlw show #f))]}) 1089 1090 (proc-doc/names 1091 test:top-level-focus-window-has? 1092 (-> (-> (is-a?/c area<%>) boolean?) boolean?) 1093 (test) 1094 @{Calls @racket[test] for each child of the @racket[test:get-active-top-level-window] 1095 and returns @racket[#t] if @racket[test] ever does, otherwise 1096 returns @racket[#f]. If there 1097 is no top-level-focus-window, returns @racket[#f].}) 1098 1099 1100 (proc-doc 1101 test:number-pending-actions 1102 (-> number?) 1103 @{Returns the number of pending events (those that haven't completed yet)}) 1104 1105 (proc-doc 1106 test:reraise-error 1107 (-> void?) 1108 @{See also @secref{test:errors}.}) 1109 1110 (proc-doc/names 1111 test:run-one 1112 (-> (-> void?) void?) 1113 (f) 1114 @{Runs the function @racket[f] as if it was a simulated event.}) 1115 1116 (parameter-doc 1117 test:use-focus-table 1118 (parameter/c (or/c boolean? 'debug)) 1119 use-focus-table? 1120 @{If @racket[#t], then the test framework uses @racket[frame:lookup-focus-table] to determine 1121 which is the focused frame. If @racket[#f], then it uses @racket[get-top-level-focus-window]. 1122 If @racket[test:use-focus-table]'s value is @racket['debug], then it still uses 1123 @racket[frame:lookup-focus-table] but it also prints a message to the @racket[current-error-port] 1124 when the two methods would give different results.}) 1125 1126 (proc-doc/names 1127 test:get-active-top-level-window 1128 (-> (or/c (is-a?/c frame%) (is-a?/c dialog%) #f)) 1129 () 1130 @{Returns the frontmost frame, based on @racket[test:use-focus-table].}) 1131 1132 (proc-doc/names 1133 label-of-enabled/shown-button-in-top-level-window? 1134 (-> string? boolean?) 1135 (label) 1136 @{Returns @racket[#t] when @racket[label] is 1137 the label of an enabled and shown 1138 @racket[button%] instance that 1139 is in the top-level window that currently 1140 has the focus, using @racket[test:top-level-focus-window-has?].}) 1141 1142 (proc-doc/names 1143 enabled-shown-button? 1144 (-> (is-a?/c button%) boolean?) 1145 (button) 1146 @{Returns @racket[#t] when @racket[button] 1147 is both enabled and shown.}) 1148 1149 (proc-doc/names 1150 button-in-top-level-focusd-window? 1151 (-> (is-a?/c button%) boolean?) 1152 (button) 1153 @{Returns @racket[#t] when @racket[button] is 1154 in the top-level focused window.}))