diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss index bce86ecdf9..96bd61ff42 100644 --- a/collects/framework/private/group.ss +++ b/collects/framework/private/group.ss @@ -273,12 +273,14 @@ (or (not (preferences:get 'framework:exit-when-no-frames)) (exit:exiting?) (not (= 1 number-of-frames)) + (current-eventspace-has-standard-menus?) (exit:user-oks-exit)))) (define (on-close-action) (when (preferences:get 'framework:exit-when-no-frames) (unless (exit:exiting?) - (when (null? (send (get-the-frame-group) get-frames)) + (when (and (null? (send (get-the-frame-group) get-frames)) + (not (current-eventspace-has-standard-menus?))) (exit:exit))))) (define (choose-a-frame parent) diff --git a/collects/tests/framework/group-test.ss b/collects/tests/framework/group-test.ss index e564e951cd..f9396d0646 100644 --- a/collects/tests/framework/group-test.ss +++ b/collects/tests/framework/group-test.ss @@ -5,7 +5,7 @@ (let ([basics (list "Bring Frame to Front..." "Most Recent Window" #f)]) (if (eq? (system-type) 'macosx) - (list* "Minimize" "Zoom" #f basics) + (list* "Minimize" "Zoom" basics) basics))) (send-sexp-to-mred '(define-syntax car* @@ -14,23 +14,32 @@ (car x) (error 'car* "got a non-pair for ~s" 'x))]))) +;; this test uses a new eventspace so that the mred function +;; current-eventspace-has-standard-menus? returns #f and thus +;; all of the platforms behave the same way. (test 'exit-on (lambda (x) (equal? x '("first"))) (lambda () + (send-sexp-to-mred `(define new-eventspace (make-eventspace))) (send-sexp-to-mred - '(begin (send (make-object frame:basic% "first") show #t) + '(begin (parameterize ([current-eventspace new-eventspace]) + (send (make-object frame:basic% "first") show #t)) (preferences:set 'framework:verify-exit #t))) - (wait-for-frame "first") + (wait-for-frame "first" 'new-eventspace) (send-sexp-to-mred - `(queue-callback (lambda () (send (get-top-level-focus-window) close)))) - (wait-for-frame "Warning") + `(queue-callback (lambda () + (parameterize ([current-eventspace new-eventspace]) + (send (get-top-level-focus-window) close))))) + (wait-for-frame "Warning" 'new-eventspace) (send-sexp-to-mred - `(test:button-push "Cancel")) - (wait-for-frame "first") + `(parameterize ([current-eventspace new-eventspace]) + (test:button-push "Cancel"))) + (wait-for-frame "first" 'new-eventspace) (send-sexp-to-mred - `(map (lambda (x) (send x get-label)) - (send (group:get-the-frame-group) get-frames))))) + `(parameterize ([current-eventspace new-eventspace]) + (map (lambda (x) (send x get-label)) + (send (group:get-the-frame-group) get-frames)))))) ;; after the first test, we should have one frame that will always ;; be in the group. diff --git a/collects/tests/framework/test-suite-utils.ss b/collects/tests/framework/test-suite-utils.ss index 0373ff76b3..8b6ccc504b 100644 --- a/collects/tests/framework/test-suite-utils.ss +++ b/collects/tests/framework/test-suite-utils.ss @@ -1,298 +1,302 @@ +#lang scheme -(module test-suite-utils mzscheme - (require launcher - mzlib/pretty - mzlib/list - mzlib/process - "debug.ss") +(require (only-in mzscheme fluid-let) + launcher + scheme/system + "debug.ss") - (provide - test-name - failed-tests +(provide + test-name + failed-tests + + ;(struct eof-result ()) + eof-result? + + load-framework-automatically + shutdown-listener shutdown-mred mred-running? + send-sexp-to-mred queue-sexp-to-mred + test + wait-for-frame + + ;; sexp -> void + ;; grabs the frontmost window, executes the sexp and waits for a new frontmost window + wait-for-new-frame + + wait-for + + reset-section-jump! + set-section-jump! + reset-section-name! + set-section-name! + set-only-these-tests! + get-only-these-tests + debug-printf + + exn->str) - ;(struct eof-result ()) - eof-result? +(define section-jump void) +(define (set-section-jump! _s) (set! section-jump _s)) +(define (reset-section-jump!) (set! section-jump #f)) - load-framework-automatically - shutdown-listener shutdown-mred mred-running? - send-sexp-to-mred queue-sexp-to-mred - test - wait-for-frame +(define section-name "<>") +(define (set-section-name! _s) (set! section-name _s)) +(define (reset-section-name!) (set! section-name "<>")) - ;; sexp -> void - ;; grabs the frontmost window, executes the sexp and waits for a new frontmost window - wait-for-new-frame +(define only-these-tests #f) +(define (get-only-these-tests) only-these-tests) +(define (set-only-these-tests! _t) (set! only-these-tests _t)) - wait-for +(define test-name "<>") +(define failed-tests null) - reset-section-jump! - set-section-jump! - reset-section-name! - set-section-name! - set-only-these-tests! - get-only-these-tests - debug-printf - - exn->str) - - (define section-jump void) - (define (set-section-jump! _s) (set! section-jump _s)) - (define (reset-section-jump!) (set! section-jump #f)) +(define-struct eof-result ()) - (define section-name "<>") - (define (set-section-name! _s) (set! section-name _s)) - (define (reset-section-name!) (set! section-name "<>")) +(define load-framework-automatically? #t) - (define only-these-tests #f) - (define (get-only-these-tests) only-these-tests) - (define (set-only-these-tests! _t) (set! only-these-tests _t)) +(define initial-port 6012) +(define port-filename + (build-path (find-system-path 'temp-dir) + "framework-tests-receive-sexps-port.ss")) - (define test-name "<>") - (define failed-tests null) +(unless (file-exists? port-filename) + (call-with-output-file port-filename + (lambda (port) (write initial-port port)))) - (define-struct eof-result ()) - - (define load-framework-automatically? #t) - - (define initial-port 6012) - (define port-filename - (build-path (find-system-path 'temp-dir) - "framework-tests-receive-sexps-port.ss")) - - (unless (file-exists? port-filename) - (call-with-output-file port-filename - (lambda (port) (write initial-port port)))) - - (define listener - (let loop ([port (call-with-input-file port-filename read)]) - (let ([l (with-handlers ([exn:fail? (lambda (_) #f)]) - (tcp-listen port))]) - (if l +(define listener + (let loop ([port (call-with-input-file port-filename read)]) + (let ([l (with-handlers ([exn:fail? (lambda (_) #f)]) + (tcp-listen port))]) + (if l (begin (debug-printf mz-tcp "listening to ~a\n" port) (call-with-output-file port-filename - (lambda (p) (write port p)) 'truncate) + (lambda (p) (write port p)) + #:exists 'truncate) l) (begin (debug-printf mz-tcp " tcp-listen failed for port ~a\n" port) (loop (add1 port))))))) - (define in-port #f) - (define out-port #f) +(define in-port #f) +(define out-port #f) - (define (restart-mred) +(define (restart-mred) + (shutdown-mred) + (thread + (lambda () + (system* + (path->string + (build-path + (let-values ([(dir exe _) + (split-path (find-system-path 'exec-file))]) + dir) + (if (eq? 'windows (system-type)) "MrEd.exe" "mred"))) + (path->string + (build-path (collection-path "tests" "framework") + "framework-test-engine.ss"))))) + (debug-printf mz-tcp "accepting listener\n") + (let-values ([(in out) (tcp-accept listener)]) + (set! in-port in) + (set! out-port out)) + (when load-framework-automatically? + (queue-sexp-to-mred + '(begin (eval '(require framework)) + (eval '(require tests/utils/gui)))))) + +(define load-framework-automatically + (case-lambda + [(new-load-framework-automatically?) + (unless (eq? (not (not new-load-framework-automatically?)) + load-framework-automatically?) + (set! load-framework-automatically? (not (not new-load-framework-automatically?))) + (shutdown-mred))] + [() load-framework-automatically?])) + +(define shutdown-listener + (lambda () (shutdown-mred) - (thread - (lambda () - (system* - (path->string - (build-path - (let-values ([(dir exe _) - (split-path (find-system-path 'exec-file))]) - dir) - (if (eq? 'windows (system-type)) "MrEd.exe" "mred"))) - (path->string - (build-path (collection-path "tests" "framework") - "framework-test-engine.ss"))))) - (debug-printf mz-tcp "accepting listener\n") - (let-values ([(in out) (tcp-accept listener)]) - (set! in-port in) - (set! out-port out)) - (when load-framework-automatically? - (queue-sexp-to-mred - '(begin (eval '(require framework)) - (eval '(require tests/utils/gui)))))) + (debug-printf mz-tcp "closing listener\n") + (tcp-close listener))) - (define load-framework-automatically - (case-lambda - [(new-load-framework-automatically?) - (unless (eq? (not (not new-load-framework-automatically?)) - load-framework-automatically?) - (set! load-framework-automatically? (not (not new-load-framework-automatically?))) - (shutdown-mred))] - [() load-framework-automatically?])) +(define shutdown-mred + (lambda () + (when (and in-port + out-port) + (with-handlers ([exn:fail? (lambda (x) (void))]) + (close-output-port out-port)) + (with-handlers ([exn:fail? (lambda (x) (void))]) + (close-input-port in-port)) + (set! in-port #f) + (set! in-port #f)))) - (define shutdown-listener - (lambda () - (shutdown-mred) - (debug-printf mz-tcp "closing listener\n") - (tcp-close listener))) +(define mred-running? + (lambda () + (if (char-ready? in-port) + (not (eof-object? (peek-char in-port))) + #t))) - (define shutdown-mred - (lambda () - (when (and in-port - out-port) - (with-handlers ([exn:fail? (lambda (x) (void))]) - (close-output-port out-port)) - (with-handlers ([exn:fail? (lambda (x) (void))]) - (close-input-port in-port)) - (set! in-port #f) - (set! in-port #f)))) +(define queue-sexp-to-mred + (lambda (sexp) + (send-sexp-to-mred + `(let ([thunk (lambda () ,sexp)] + [sema (make-semaphore 0)]) + (queue-callback (lambda () + (thunk) + (semaphore-post sema))) + (semaphore-wait sema))))) - (define mred-running? - (lambda () - (if (char-ready? in-port) - (not (eof-object? (peek-char in-port))) - #t))) +(define re:tcp-read-error (regexp "tcp-read:")) +(define re:tcp-write-error (regexp "tcp-write:")) +(define (tcp-error? exn) + (or (regexp-match re:tcp-read-error (exn-message exn)) + (regexp-match re:tcp-write-error (exn-message exn)))) - (define queue-sexp-to-mred - (lambda (sexp) - (send-sexp-to-mred - `(let ([thunk (lambda () ,sexp)] - [sema (make-semaphore 0)]) - (queue-callback (lambda () - (thunk) - (semaphore-post sema))) - (semaphore-wait sema))))) +(namespace-require 'scheme) ;; in order to make the eval below work right. +(define (send-sexp-to-mred sexp) + (let/ec k + (let ([show-text + (lambda (sexp) + (debug-when messages + (parameterize ([pretty-print-print-line + (let ([prompt " "] + [old-liner (pretty-print-print-line)]) + (lambda (ln port ol cols) + (let ([ov (old-liner ln port ol cols)]) + (if ln + (begin (display prompt port) + (+ (string-length prompt) ov)) + ov))))]) + (pretty-print sexp) + (newline))))]) + (unless (and in-port + out-port + (with-handlers ([tcp-error? (lambda (x) #f)]) + (or (not (char-ready? in-port)) + (not (eof-object? (peek-char in-port)))))) + (restart-mred)) + (debug-printf messages " ~a // ~a: sending to mred:\n" + section-name test-name) + (show-text sexp) + (with-handlers ([exn:fail? + (lambda (x) + (cond + ;; this means that mred was closed + ;; so we can restart it and try again. + [(tcp-error? x) + (restart-mred) + (write sexp out-port) + (newline out-port) + (flush-output out-port)] + [else (raise x)]))]) + (write sexp out-port) + (newline out-port) + (flush-output out-port)) + (let ([answer + (with-handlers ([exn:fail? + (lambda (x) + (if (tcp-error? x);; assume tcp-error means app closed + eof + (list 'cant-read + (string-append + (exn->str x) + "; rest of string: " + (format + "~s" + (apply + string + (let loop () + (if (char-ready? in-port) + (let ([char (read-char in-port)]) + (if (eof-object? char) + null + (cons char (loop)))) + null))))))))]) + (read in-port))]) + (debug-printf messages " ~a // ~a: received from mred:\n" section-name test-name) + (show-text answer) + (unless (or (eof-object? answer) + (and (list? answer) + (= 2 (length answer)) + (memq (car answer) + '(error last-error cant-read normal)))) + (error 'send-sexp-to-mred "unpected result from mred: ~s\n" answer)) + (if (eof-object? answer) + (raise (make-eof-result)) + (case (car answer) + [(error) + (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))] + [(last-error) + (error 'send-sexp-to-mred "mred (last time) raised \"~a\"" (second answer))] + [(cant-read) (error 'mred/cant-parse (second answer))] + [(normal) + (eval (second answer))])))))) - (define re:tcp-read-error (regexp "tcp-read:")) - (define re:tcp-write-error (regexp "tcp-write:")) - (define (tcp-error? exn) - (or (regexp-match re:tcp-read-error (exn-message exn)) - (regexp-match re:tcp-write-error (exn-message exn)))) +(define test + (case-lambda + [(in-test-name passed? sexp/proc) (test in-test-name passed? sexp/proc 'section)] + [(in-test-name passed? sexp/proc jump) + (fluid-let ([test-name in-test-name]) + (when (or (not only-these-tests) + (memq test-name only-these-tests)) + (let* ([result + (with-handlers ([exn:fail? + (lambda (x) + (if (exn? x) + (exn->str x) + x))]) + (if (procedure? sexp/proc) + (sexp/proc) + (begin0 (send-sexp-to-mred sexp/proc) + (send-sexp-to-mred ''check-for-errors))))] + [failed (with-handlers ([exn:fail? + (lambda (x) + (string-append + "passed? test raised exn: " + (if (exn? x) + (exn->str x) + (format "~s" x))))]) + (not (passed? result)))]) + (when failed + (debug-printf schedule "FAILED ~a:\n ~s\n" test-name result) + (set! failed-tests (cons (cons section-name test-name) failed-tests)) + (case jump + [(section) (section-jump)] + [(continue) (void)] + [else (jump)])))))])) - (namespace-require 'scheme) ;; in order to make the eval below work right. - (define (send-sexp-to-mred sexp) - (let/ec k - (let ([show-text - (lambda (sexp) - (debug-when messages - (parameterize ([pretty-print-print-line - (let ([prompt " "] - [old-liner (pretty-print-print-line)]) - (lambda (ln port ol cols) - (let ([ov (old-liner ln port ol cols)]) - (if ln - (begin (display prompt port) - (+ (string-length prompt) ov)) - ov))))]) - (pretty-print sexp) - (newline))))]) - (unless (and in-port - out-port - (with-handlers ([tcp-error? (lambda (x) #f)]) - (or (not (char-ready? in-port)) - (not (eof-object? (peek-char in-port)))))) - (restart-mred)) - (debug-printf messages " ~a // ~a: sending to mred:\n" - section-name test-name) - (show-text sexp) - (with-handlers ([exn:fail? - (lambda (x) - (cond - ;; this means that mred was closed - ;; so we can restart it and try again. - [(tcp-error? x) - (restart-mred) - (write sexp out-port) - (newline out-port) - (flush-output out-port)] - [else (raise x)]))]) - (write sexp out-port) - (newline out-port) - (flush-output out-port)) - (let ([answer - (with-handlers ([exn:fail? - (lambda (x) - (if (tcp-error? x);; assume tcp-error means app closed - eof - (list 'cant-read - (string-append - (exn->str x) - "; rest of string: " - (format - "~s" - (apply - string - (let loop () - (if (char-ready? in-port) - (let ([char (read-char in-port)]) - (if (eof-object? char) - null - (cons char (loop)))) - null))))))))]) - (read in-port))]) - (debug-printf messages " ~a // ~a: received from mred:\n" section-name test-name) - (show-text answer) - (unless (or (eof-object? answer) - (and (list? answer) - (= 2 (length answer)) - (memq (car answer) - '(error last-error cant-read normal)))) - (error 'send-sexp-to-mred "unpected result from mred: ~s\n" answer)) - (if (eof-object? answer) - (raise (make-eof-result)) - (case (car answer) - [(error) - (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))] - [(last-error) - (error 'send-sexp-to-mred "mred (last time) raised \"~a\"" (second answer))] - [(cant-read) (error 'mred/cant-parse (second answer))] - [(normal) - (eval (second answer))])))))) +(define (exn->str exn) + (let ([sp (open-output-string)]) + (parameterize ([current-error-port sp]) + ((error-display-handler) (exn-message exn) exn)) + (get-output-string sp))) - (define test - (case-lambda - [(in-test-name passed? sexp/proc) (test in-test-name passed? sexp/proc 'section)] - [(in-test-name passed? sexp/proc jump) - (fluid-let ([test-name in-test-name]) - (when (or (not only-these-tests) - (memq test-name only-these-tests)) - (let* ([result - (with-handlers ([exn:fail? - (lambda (x) - (if (exn? x) - (exn->str x) - x))]) - (if (procedure? sexp/proc) - (sexp/proc) - (begin0 (send-sexp-to-mred sexp/proc) - (send-sexp-to-mred ''check-for-errors))))] - [failed (with-handlers ([exn:fail? - (lambda (x) - (string-append - "passed? test raised exn: " - (if (exn? x) - (exn->str x) - (format "~s" x))))]) - (not (passed? result)))]) - (when failed - (debug-printf schedule "FAILED ~a:\n ~s\n" test-name result) - (set! failed-tests (cons (cons section-name test-name) failed-tests)) - (case jump - [(section) (section-jump)] - [(continue) (void)] - [else (jump)])))))])) +(define (wait-for/wrapper wrapper sexp) + (let ([timeout 10] + [pause-time 1/2]) + (send-sexp-to-mred + (wrapper + `(let ([test (lambda () ,sexp)]) + (let loop ([n ,(/ timeout pause-time)]) + (if (zero? n) + (error 'wait-for + ,(format "after ~a seconds, ~s didn't come true" timeout sexp)) + (unless (test) + (sleep ,pause-time) + (loop (- n 1)))))))))) - (define (exn->str exn) - (let ([sp (open-output-string)]) - (parameterize ([current-error-port sp]) - ((error-display-handler) (exn-message exn) exn)) - (get-output-string sp))) - - (define (wait-for/wrapper wrapper sexp) - (let ([timeout 10] - [pause-time 1/2]) - (send-sexp-to-mred - (wrapper - `(let ([test (lambda () ,sexp)]) - (let loop ([n ,(/ timeout pause-time)]) - (if (zero? n) - (error 'wait-for - ,(format "after ~a seconds, ~s didn't come true" timeout sexp)) - (unless (test) - (sleep ,pause-time) - (loop (- n 1)))))))))) +(define (wait-for sexp) (wait-for/wrapper (lambda (x) x) sexp)) - (define (wait-for sexp) (wait-for/wrapper (lambda (x) x) sexp)) +(define (wait-for-new-frame sexp) + (wait-for/wrapper + (lambda (w) + `(let ([frame (get-top-level-focus-window)]) + ,sexp + ,w)) + `(not (eq? frame (get-top-level-focus-window))))) - (define (wait-for-new-frame sexp) - (wait-for/wrapper - (lambda (w) - `(let ([frame (get-top-level-focus-window)]) - ,sexp - ,w)) - `(not (eq? frame (get-top-level-focus-window))))) - - (define (wait-for-frame name) - (wait-for `(let ([win (get-top-level-focus-window)]) - (and win - (string=? (send win get-label) ,name)))))) +(define (wait-for-frame name [eventspace #f]) + (let ([exp `(let ([win (get-top-level-focus-window)]) + (and win + (string=? (send win get-label) ,name)))]) + (if eventspace + `(parameterize ([current-eventspace ,eventspace]) + ,exp) + (wait-for exp))))