PR 9873 (hopefully)

svn: r12193

original commit: bd375ef6050111faa3bc8855679d06f537966df9

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)

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))))
+    `(queue-callback (lambda () 
-   (wait-for-frame "Warning")
+                       (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"))
+    `(parameterize ([current-eventspace new-eventspace])
-   (wait-for-frame "first")
+       (test:button-push "Cancel")))
+   (wait-for-frame "first" 'new-eventspace)
    (send-sexp-to-mred
-    `(map (lambda (x) (send x get-label))
+    `(parameterize ([current-eventspace new-eventspace])
-          (send (group:get-the-frame-group) get-frames)))))
+       (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.

collects/tests/framework/test-suite-utils.ss

@@ -1,12 +1,11 @@
+#lang scheme
 
-(module test-suite-utils mzscheme
+(require (only-in mzscheme fluid-let)
-  (require launcher
+         launcher
-	   mzlib/pretty
+         scheme/system
-	   mzlib/list
-           mzlib/process
          "debug.ss")
 
-  (provide
+(provide
  test-name
  failed-tests
  
@@ -35,50 +34,51 @@
  
  exn->str)
 
-  (define section-jump void)
+(define section-jump void)
-  (define (set-section-jump! _s) (set! section-jump _s))
+(define (set-section-jump! _s) (set! section-jump _s))
-  (define (reset-section-jump!) (set! section-jump #f))
+(define (reset-section-jump!) (set! section-jump #f))
 
-  (define section-name "<<setup>>")
+(define section-name "<<setup>>")
-  (define (set-section-name! _s) (set! section-name _s))
+(define (set-section-name! _s) (set! section-name _s))
-  (define (reset-section-name!) (set! section-name "<<setup>>"))
+(define (reset-section-name!) (set! section-name "<<setup>>"))
 
-  (define only-these-tests #f)
+(define only-these-tests #f)
-  (define (get-only-these-tests) only-these-tests)
+(define (get-only-these-tests) only-these-tests)
-  (define (set-only-these-tests! _t) (set! only-these-tests _t))
+(define (set-only-these-tests! _t) (set! only-these-tests _t))
 
-  (define test-name "<<setup>>")
+(define test-name "<<setup>>")
-  (define failed-tests null)
+(define failed-tests null)
 
-  (define-struct eof-result ())
+(define-struct eof-result ())
 
-  (define load-framework-automatically? #t)
+(define load-framework-automatically? #t)
 
-  (define initial-port 6012)
+(define initial-port 6012)
-  (define port-filename
+(define port-filename
   (build-path (find-system-path 'temp-dir)
               "framework-tests-receive-sexps-port.ss"))
 
-  (unless (file-exists? port-filename)
+(unless (file-exists? port-filename)
   (call-with-output-file port-filename
     (lambda (port) (write initial-port port))))
 
-  (define listener
+(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 in-port #f)
-  (define out-port #f)
+(define out-port #f)
 
-  (define (restart-mred)
+(define (restart-mred)
   (shutdown-mred)
   (thread
    (lambda ()
@@ -101,7 +101,7 @@
      '(begin (eval '(require framework))
              (eval '(require tests/utils/gui))))))
 
-  (define load-framework-automatically
+(define load-framework-automatically
   (case-lambda
     [(new-load-framework-automatically?)
      (unless (eq? (not (not new-load-framework-automatically?))
@@ -110,13 +110,13 @@
        (shutdown-mred))]
     [() load-framework-automatically?]))
 
-  (define shutdown-listener
+(define shutdown-listener
   (lambda ()
     (shutdown-mred)
     (debug-printf mz-tcp "closing listener\n")
     (tcp-close listener)))
 
-  (define shutdown-mred
+(define shutdown-mred
   (lambda ()
     (when (and in-port
                out-port)
@@ -127,13 +127,13 @@
       (set! in-port #f)
       (set! in-port #f))))
 
-  (define mred-running?
+(define mred-running?
   (lambda ()
     (if (char-ready? in-port)
         (not (eof-object? (peek-char in-port)))
         #t)))
 
-  (define queue-sexp-to-mred
+(define queue-sexp-to-mred
   (lambda (sexp)
     (send-sexp-to-mred
      `(let ([thunk (lambda () ,sexp)]
@@ -143,14 +143,14 @@
                           (semaphore-post sema)))
         (semaphore-wait sema)))))
 
-  (define re:tcp-read-error (regexp "tcp-read:"))
+(define re:tcp-read-error (regexp "tcp-read:"))
-  (define re:tcp-write-error (regexp "tcp-write:"))
+(define re:tcp-write-error (regexp "tcp-write:"))
-  (define (tcp-error? exn)
+(define (tcp-error? exn)
   (or (regexp-match re:tcp-read-error (exn-message exn))
       (regexp-match re:tcp-write-error (exn-message exn))))
 
-  (namespace-require 'scheme) ;; in order to make the eval below work right.
+(namespace-require 'scheme) ;; in order to make the eval below work right.
-  (define (send-sexp-to-mred sexp)
+(define (send-sexp-to-mred sexp)
   (let/ec k
     (let ([show-text
            (lambda (sexp)
@@ -229,7 +229,7 @@
               [(normal) 
                (eval (second answer))]))))))
 
-  (define test
+(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)
@@ -262,13 +262,13 @@
                [(continue) (void)]
                [else (jump)])))))]))
 
-  (define (exn->str exn)
+(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)
+(define (wait-for/wrapper wrapper sexp)
   (let ([timeout 10]
         [pause-time 1/2])
     (send-sexp-to-mred
@@ -282,9 +282,9 @@
                  (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)
+(define (wait-for-new-frame sexp)
   (wait-for/wrapper
    (lambda (w)
      `(let ([frame (get-top-level-focus-window)])
@@ -292,7 +292,11 @@
         ,w))
    `(not (eq? frame (get-top-level-focus-window)))))
 
-  (define (wait-for-frame name)
+(define (wait-for-frame name [eventspace #f])
-    (wait-for `(let ([win (get-top-level-focus-window)])
+  (let ([exp `(let ([win (get-top-level-focus-window)])
                 (and win
-		      (string=? (send win get-label) ,name))))))
+                     (string=? (send win get-label) ,name)))])
+    (if eventspace
+        `(parameterize ([current-eventspace ,eventspace])
+           ,exp)
+        (wait-for exp))))