;;; util.ss ;;; utility functions for DrScheme GUI testing ;;; Authors: Robby Findler, Paul Steckler (module drscheme-test-util mzscheme (require (prefix fw: (lib "framework.ss" "framework")) (lib "hierlist.ss" "hierlist") (lib "mred.ss" "mred") (lib "class.ss") (lib "list.ss") (lib "contract.ss") (lib "etc.ss") (lib "gui.ss" "tests" "utils") (lib "contract.ss")) (provide/contract [use-get/put-dialog ((-> any) path? . -> . void?)]) (provide save-drscheme-window-as do-execute test-util-error poll-until wait-for-computation wait-for-drscheme-frame wait-for-new-frame clear-definitions type-in-definitions type-in-interactions type-string wait wait-pending get-sub-panel get-text-pos wait-for-button push-button-and-wait set-language-level! repl-in-edit-sequence? fetch-output has-error? run-one/sync) ;; save-drscheme-window-as : string -> void ;; use the "save as" dialog in drscheme to save the definitions ;; window to a file. (define (save-drscheme-window-as filename) (use-get/put-dialog (lambda () (fw:test:menu-select "File" "Save Definitions As...")) filename)) ;; open-dialog is a thunk that should open the dialog ;; filename is a string naming a file that should be typed into the dialog (define (use-get/put-dialog open-dialog filename) (let ([drs (wait-for-drscheme-frame)]) (with-handlers ([(lambda (x) #t) (lambda (x) (fw:preferences:set 'framework:file-dialogs 'std) (raise x))]) (fw:preferences:set 'framework:file-dialogs 'common) (open-dialog) (let ([dlg (wait-for-new-frame drs)]) (send (find-labelled-window "Full pathname") focus) (fw:test:keystroke #\a (list (case (system-type) [(windows) 'control] [(macosx macos) 'meta] [(unix) 'meta] [else (error 'use-get/put-dialog "unknown platform: ~s\n" (system-type))]))) (for-each fw:test:keystroke (string->list (path->string filename))) (fw:test:button-push "OK") (wait-for-new-frame dlg)) (fw:preferences:set 'framework:file-dialogs 'std)))) (define (test-util-error fmt . args) (raise (make-exn (apply fmt args) (current-continuation-marks)))) ;; poll-until : (-> alpha) number (-> alpha) -> alpha ;; waits until pred return a true value and returns that. ;; if that doesn't happen by `secs', calls fail and returns that. (define poll-until (opt-lambda (pred [secs 10] [fail (lambda () (error 'poll-until "timeout after ~e secs, ~e never returned a true value" secs pred))]) (let ([step 1/20]) (let loop ([counter secs]) (if (<= counter 0) (fail) (let ([result (pred)]) (or result (begin (sleep step) (loop (- counter step)))))))))) (define (drscheme-frame? frame) (method-in-interface? 'get-execute-button (object-interface frame))) (define wait-for-drscheme-frame (case-lambda [() (wait-for-drscheme-frame #t)] [(print-message?) (let ([wait-for-drscheme-frame-pred (lambda () (let ([active (get-top-level-focus-window)]) (if (and active (drscheme-frame? active)) active #f)))]) (or (wait-for-drscheme-frame-pred) (begin (when print-message? (printf "Select DrScheme frame~n")) (poll-until wait-for-drscheme-frame-pred))))])) ;; wait-for-new-frame : frame [(listof eventspace) = null] -> frame ;; returns the newly opened frame, waiting until old-frame ;; is no longer frontmost. Optionally checks other eventspaces ;; waits until the new frame has a focus'd window, too. (define wait-for-new-frame (case-lambda [(old-frame) (wait-for-new-frame old-frame null)] [(old-frame extra-eventspaces) (wait-for-new-frame old-frame extra-eventspaces 10)] [(old-frame extra-eventspaces timeout) (let ([wait-for-new-frame-pred (lambda () (let ([active (or (get-top-level-focus-window) (ormap (lambda (eventspace) (parameterize ([current-eventspace eventspace]) (get-top-level-focus-window))) extra-eventspaces))]) (if (and active (send active get-focus-window) (not (eq? active old-frame))) active #f)))]) (poll-until wait-for-new-frame-pred timeout))])) ;; wait-for-computation : frame -> void ;; waits until the drscheme frame finishes some computation. ;; uses the state of the execute button to indicate when the ;; computations is finished. That is, waits for the execute ;; button to dim, indicating a computation is running. Then, ;; waits for it to be re-enabled, indicating that the computation ;; is complete. (define (wait-for-computation frame) (verify-drscheme-frame-frontmost 'wait-for-computation frame) (let* ([wait-for-computation-to-start (lambda () (fw:test:reraise-error) (not (send (send frame get-execute-button) is-enabled?)))] [wait-for-computation-to-finish (lambda () (fw:test:reraise-error) (send (send frame get-execute-button) is-enabled?))]) ;(poll-until wait-for-computation-to-start 60) ;; hm. (poll-until wait-for-computation-to-finish 60))) (define do-execute (case-lambda [(frame) (do-execute frame #t)] [(frame wait-for-finish?) (verify-drscheme-frame-frontmost 'do-execute frame) (let ([button (send frame get-execute-button)]) (fw:test:button-push button) (when wait-for-finish? (wait-for-computation frame)))])) (define (verify-drscheme-frame-frontmost function-name frame) (unless (and (eq? frame (get-top-level-focus-window)) (drscheme-frame? frame)) (error function-name "drscheme frame not frontmost: ~e" frame))) (define (clear-definitions frame) (verify-drscheme-frame-frontmost 'clear-definitions frame) (fw:test:new-window (send frame get-definitions-canvas)) (let ([window (send frame get-focus-window)]) (let-values ([(cw ch) (send window get-client-size)] [(w h) (send window get-size)]) (fw:test:mouse-click 'left (inexact->exact (+ cw (floor (/ (- w cw) 2)))) (inexact->exact (+ ch (floor (/ (- h ch) 2))))))) (fw:test:menu-select "Edit" "Select All") (fw:test:menu-select "Edit" (if (eq? (system-type) 'macos) "Clear" "Delete"))) (define (type-in-definitions frame str) (type-in-definitions/interactions (lambda (x) (send x get-definitions-canvas)) frame str)) (define (type-in-interactions frame str) (type-in-definitions/interactions (lambda (x) (send x get-interactions-canvas)) frame str)) (define (type-in-definitions/interactions get-canvas frame str/sexp) (let ([str (if (string? str/sexp) str/sexp (let ([port (open-output-string)]) (parameterize ([current-output-port port]) (write str/sexp port)) (get-output-string port)))]) (verify-drscheme-frame-frontmost 'type-in-definitions/interactions frame) (let ([canvas (get-canvas frame)]) (fw:test:new-window canvas) (send (send canvas get-editor) set-caret-owner #f) (type-string str)))) ;; type-string : string -> void ;; to call test:keystroke repeatedly with the characters (define (type-string str) (let ([len (string-length str)]) (let loop ([i 0]) (unless (>= i len) (let ([c (string-ref str i)]) (fw:test:keystroke (if (char=? c #\newline) #\return c))) (loop (+ i 1)))))) (define wait (case-lambda [(test desc-string) (wait test desc-string 5)] [(test desc-string time) (let ([int 1/2]) (let loop ([sofar 0]) (cond [(> sofar time) (error 'wait desc-string)] [(test) (void)] [else (sleep int) (loop (+ sofar int))])))])) (define (wait-pending) (wait (lambda () (= 0 (fw:test:number-pending-actions))) "Pending actions didn't terminate") (fw:test:reraise-error)) ;;; get-sub-panel takes ;;; a list of integers describing the path from a frame to the desired panel ;;; the frame ;;; based on code by Mark Krentel ;;; Examples: ;;; (get-sub-panel '() frame) gets the top-panel in frame ;;; (get-sub-panel '(2) frame) gets the 2nd child of the top-panel ;;; (get-sub-panel '(2 0) frame) gets the 0th child of the 2nd child of the top-panel (define (get-sub-panel path frame) (letrec ([loop (lambda (path panel) (if (null? path) (if (is-a? panel panel%) panel (test-util-error "not a panel")) (loop (cdr path) (list-ref (send panel get-children) (car path)))))]) (loop path frame))) ;;; get-text-pos returns the offset in an text buffer of the beginning ;;; of the last line (define (get-text-pos text) (let* ([last-pos (send text last-position)] [last-line (send text position-line last-pos)]) (send text line-start-position last-line))) ; poll for enabled button (define (wait-for-button button) (poll-until (let ([wait-for-button-pred (lambda () (send button is-enabled?))]) wait-for-button-pred))) (define (push-button-and-wait button) (fw:test:button-push button) (poll-until (let ([button-push-and-wait-pred (lambda () (fw:test:reraise-error) (= 0 (fw:test:number-pending-actions)))]) button-push-and-wait-pred)) (wait-for-button button)) ;; set-language-level! : (cons (union regexp string) (listof (union regexp string))) boolean -> void ;; set language level in the frontmost DrScheme frame (resets settings to defaults) ;; If `close-dialog?' it #t, (define set-language-level! (opt-lambda (in-language-spec [close-dialog? #t]) (unless (and (pair? in-language-spec) (list? in-language-spec) (andmap (lambda (x) (or string? regexp?)) in-language-spec)) (error 'set-language-level! "expected a non-empty list of regexps and strings for language, got: ~e" in-language-spec)) (let ([drs-frame (get-top-level-focus-window)]) (fw:test:menu-select "Language" "Choose Language...") (let* ([language-dialog (wait-for-new-frame drs-frame)] [language-choice (find-labelled-window #f hierarchical-list%)] [b1 (box 0)] [b2 (box 0)] [click-on-snip (lambda (snip) (let* ([editor (send (send snip get-admin) get-editor)] [between-threshold (send editor get-between-threshold)]) (send editor get-snip-location snip b1 b2) (let-values ([(gx gy) (send editor editor-location-to-dc-location (unbox b1) (unbox b2))]) (let ([x (inexact->exact (+ gx between-threshold 1))] [y (inexact->exact (+ gy between-threshold 1))]) (fw:test:mouse-click 'left x y)))))]) (send language-choice focus) (let loop ([list-item language-choice] [language-spec in-language-spec]) (let* ([name (car language-spec)] [which (filter (lambda (child) (let* ([text (send (send child get-editor) get-text)] [matches (or (and (regexp? name) (regexp-match name text)) (and (string? name) (string=? name text)))]) (and matches child))) (send list-item get-items))]) (when (null? which) (error 'set-language-level! "couldn't find language: ~e, no match at ~e" in-language-spec name)) (unless (= 1 (length which)) (error 'set-language-level! "couldn't find language: ~e, double match ~e" in-language-spec name)) (let ([next-item (car which)]) (cond [(null? (rest language-spec)) (when (is-a? next-item hierarchical-list-compound-item<%>) (error 'set-language-level! "expected no more languages after ~e, but still are, input ~e" name in-language-spec)) (click-on-snip (send next-item get-clickable-snip))] [else (unless (is-a? next-item hierarchical-list-compound-item<%>) (error 'set-language-level! "expected more languages after ~e, but got to end, input ~e" name in-language-spec)) (unless (send next-item is-open?) (click-on-snip (send next-item get-arrow-snip))) (loop next-item (cdr language-spec))])))) (with-handlers ([exn:fail? (lambda (x) (void))]) (fw:test:button-push "Show Details")) (fw:test:button-push "Revert to Language Defaults") (when close-dialog? (fw:test:button-push "OK") (let ([new-frame (wait-for-new-frame language-dialog)]) (unless (eq? new-frame drs-frame) (error 'set-language-level! "didn't get drscheme frame back, got: ~s\n" new-frame)))))))) (provide/contract [check-language-level ((union string? regexp?) . -> . void?)]) ;; checks that the language in the drscheme window is set to the given one. ;; clears the definitions, clicks execute and checks the interactions window. (define (check-language-level lang-spec) (let* ([drs-frame (get-top-level-focus-window)] [interactions (send drs-frame get-interactions-text)] [definitions-canvas (send drs-frame get-definitions-canvas)]) (fw:test:new-window definitions-canvas) (fw:test:menu-select "Edit" "Select All") (fw:test:menu-select "Edit" "Delete") (do-execute drs-frame) (let ([lang-line (send interactions get-text (send interactions line-start-position 1) (send interactions line-end-position 1))]) (unless (regexp-match lang-spec lang-line) (error 'check-language-level "expected ~s to match ~s" lang-line lang-spec))))) (define (repl-in-edit-sequence?) (send (send (wait-for-drscheme-frame) get-interactions-text) refresh-delayed?)) ;; has-error? : frame -> (union #f string) ;; returns the error text of an error in the interactions window of the frame or #f if there is none. ;; ensures that frame is front most. (define (has-error? frame) (run-one/sync (lambda () (verify-drscheme-frame-frontmost 'had-error? frame) (let* ([interactions-text (send frame get-interactions-text)] [last-para (send interactions-text last-paragraph)]) (unless (>= last-para 2) (error 'has-error? "expected at least 2 paragraphs in interactions window, found ~a" (+ last-para 1))) (let ([start (send interactions-text paragraph-start-position 2)] [end (send interactions-text paragraph-end-position (- (send interactions-text last-paragraph) 1))]) (send interactions-text split-snip start) (send interactions-text split-snip end) (let loop ([pos start]) (cond [(<= end pos) #f] [else (let ([snip (send interactions-text find-snip pos 'after-or-none)]) (cond [(not snip) #f] [else (let ([color (send (send snip get-style) get-foreground)]) (if (and (= 255 (send color red)) (= 0 (send color blue) (send color green))) ;; return the text of the entire line containing the red text (let ([para (send interactions-text position-paragraph pos)]) (send interactions-text get-text (send interactions-text paragraph-start-position para) (send interactions-text paragraph-end-position para))) (loop (+ pos (send snip get-count)))))]))]))))))) (define fetch-output (case-lambda [(frame) (fetch-output frame #f #f)] [(frame _start _end) (run-one/sync (lambda () (verify-drscheme-frame-frontmost 'fetch-output frame) (let-values ([(start end) (if (and _start _end) (values _start _end) (let* ([interactions-text (send frame get-interactions-text)] [last-para (send interactions-text last-paragraph)]) (unless (>= last-para 2) (error 'fetch-output "expected at least 2 paragraphs in interactions window, found ~a" (+ last-para 1))) (values (send interactions-text paragraph-start-position 2) (send interactions-text paragraph-end-position (- (send interactions-text last-paragraph) 1)))))]) (let ([interactions-text (send frame get-interactions-text)]) (send interactions-text split-snip start) (send interactions-text split-snip end) (let loop ([snip (send interactions-text find-snip end 'before)] [strings null]) (cond [(< (send interactions-text get-snip-position snip) start) (apply string-append strings)] [else (cond [(is-a? snip string-snip%) (loop (send snip previous) (cons (send snip get-text 0 (send snip get-count)) strings))] [(is-a? snip editor-snip%) (let ([editor (send snip get-editor)]) (cond [(is-a? editor pasteboard%) (loop (send snip previous) (cons "" strings))] [(is-a? editor text%) (loop (send snip previous) (list* "{embedded \"" (send editor get-text) "\"}" strings))]))] [(is-a? snip image-snip%) (loop (send snip previous) (cons (with-handlers ([exn:fail? (lambda (x) "{image}")]) (format "{~a}" (send snip get-image-name))) strings))] [;; this test is an approximation of ;; (is-a? snip drscheme:snip:number-snip%) (and (method-in-interface? 'get-fraction-view (object-interface snip))) (loop (send snip previous) (cons (format "{number ~s ~s ~s}" (send snip get-number) (send snip get-text 0 (send snip get-count)) (send snip get-fraction-view)) strings))] [else (error 'find-output "{unknown snip: ~e}~n" snip)])]))))))])) ;; run-one/sync : (-> A) -> A ;; runs the thunk `f' as a test action, and ;; waits for it to complete. Also propogates ;; exceptions. (define (run-one/sync f) (let ([s (make-semaphore 0)] [exn #f] [anss #f]) (fw:test:run-one (lambda () (with-handlers ([exn:fail? (lambda (exn) (set! exn exn))]) (call-with-values f (lambda x (set! anss x)))) (semaphore-post s))) (semaphore-wait s) (if anss (apply values anss) (raise exn)))))