...

original commit: c2b59fb0a7bb6d526b8352c8f94fcc9dac21b972

collects/framework/frame.ss

@@ -73,8 +73,11 @@
 	     (show #f)))])
       (sequence
 	(apply super-init args)
-	(send (group:get-the-frame-group) insert-frame this)
-	(make-object (get-menu-bar%) this))
+
+	;; must make menu before inserting frame into group
+	;; or initial windows menu will be wrong
+	(make-object menu% "Windows" (make-object (get-menu-bar%) this))
+	(send (group:get-the-frame-group) insert-frame this))
       (private
 	[panel (make-root-area-container (get-area-container%) this)])
       (public

collects/framework/frameworks.ss

@@ -4,6 +4,7 @@
 (compile-allow-set!-undefined #t)
 
 (require-library "refer.ss")
+(require-library "macro.ss")
 (require-library "cores.ss")
 (require-library "dates.ss")
 (require-library "match.ss")

collects/framework/group.ss

@@ -21,13 +21,19 @@
       (private
 	[get-windows-menu
 	 (lambda (frame)
-	   (and (ivar-in-class? 'windows-menu (object-class frame))
-		(ivar frame windows-menu)))]
+	   (let ([menu-bar (send frame get-menu-bar)])
+	     (and menu-bar
+		  (let ([menus (send menu-bar get-items)])
+		    (ormap (lambda (x)
+			     (if (string=? "Windows" (send x get-label))
+				 x
+				 #f))
+			   menus)))))]
 	[insert-windows-menu
 	 (lambda (frame)
 	   (let ([menu (get-windows-menu frame)])
 	     (when menu
-	       (set! windows-menus (cons (list menu) windows-menus)))))]
+	       (set! windows-menus (cons menu windows-menus)))))]
 	[remove-windows-menu
 	 (lambda (frame)
 	   (let* ([menu (get-windows-menu frame)])
@@ -35,47 +41,43 @@
 		   (mzlib:function:remove
 		    menu
 		    windows-menus
-		    (lambda (x y)
-		      (eq? x (car y)))))))]
+		    eq?))))]
 
 	[update-windows-menus
 	 (lambda ()
 	   (let* ([windows (length windows-menus)]
-		  [get-name (lambda (frame) (send (frame-frame frame) get-label))]
+		  [default-name "Untitled"]
+		  [get-name 
+		   (lambda (frame)
+		     (let ([label (send frame get-label)])
+		       (if (string=? label "")
+			   (if (ivar-in-class? 'get-entire-label (object-class frame))
+			       (let ([label (send frame get-entire-label)])
+				 (if (string=? label "")
+				     default-name
+				     label))
+			       default-name)
+			   label)))]
 		  [sorted-frames
 		   (mzlib:function:quicksort
 		    frames
 		    (lambda (f1 f2)
-		      (string-ci<=? (get-name f1)
-				    (get-name f2))))])
-	     (set!
-	      windows-menus
-	      (map
-	       (lambda (menu-list)
-		 (let ([menu (car menu-list)]
-		       [old-ids (cdr menu-list)])
-		   (for-each (lambda (id) (send menu delete id))
-			     old-ids)
-		   (let ([new-ids
-			  (map
-			   (lambda (frame)
-			     (let ([frame (frame-frame frame)]
-				   [default-name "Untitled"])
-			       (send menu append-item
-				     (let ([label (send frame get-label)])
-				       (if (string=? label "")
-					   (if (ivar-in-class? 'get-entire-label (object-class frame))
-					       (let ([label (send frame get-entire-label)])
-						 (if (string=? label "")
-						     default-name
-						     label))
-					       default-name)
-					   label))
-				     (lambda ()
-				       (send frame show #t)))))
-			   sorted-frames)])
-		     (cons menu new-ids))))
-	       windows-menus))))])
+		      (string-ci<=? (get-name (frame-frame f1))
+				    (get-name (frame-frame f2)))))])
+	      (for-each
+	       (lambda (menu)
+		 (for-each (lambda (item) (send item delete))
+			   (send menu get-items))
+		 (for-each
+		  (lambda (frame)
+		    (let ([frame (frame-frame frame)])
+		      (make-object menu-item% (get-name frame)
+				   menu
+				   (lambda (_1 _2)
+				     (send frame show #t)))))
+		  sorted-frames)
+		 (newline))
+	       windows-menus)))])
       
       (private
 	[update-close-menu-item-state

collects/framework/guiutils.ss

@@ -107,7 +107,7 @@
   
   (define get-choice
     (opt-lambda (message true-choice false-choice [title "Warning"])
-      (letrec ([result (void)]
+      (letrec ([result #f]
 	       [dialog (make-object dialog% title)]
 	       [on-true
 		(lambda args

collects/framework/main.ss

@@ -49,7 +49,7 @@
 		 define-some do opt-lambda send*
 		 local catch shared
 		 unit/sig
-		 with-handlers with-parameterization
+		 with-handlers
 		 interface
 		 parameterize
 		 call-with-input-file with-input-from-file
@@ -178,21 +178,21 @@
 			(set! test #f)
 			(semaphore-post s))))))))
   
-  (preferences:set-default 'framework:just-exit-when-no-frames #t boolean?)
+  (preferences:set-default 'framework:exit-when-no-frames #f boolean?)
 
   (let ([at-most-one (at-most-one-maker)])
     (send (group:get-the-frame-group) set-empty-callbacks
 	  (lambda () 
-	    (if (preferences:get 'framework:just-exit-when-no-frames)
-		(void)
+	    (if (preferences:get 'framework:exit-when-no-frames)
 		(at-most-one (void) 
-			     (lambda () (exit:exit #t)))))
+			     (lambda () (exit:exit #t)))
+		(void)))
 	  (lambda ()
-	    (if (preferences:get 'framework:just-exit-when-no-frames)
-		#t
+	    (if (preferences:get 'framework:exit-when-no-frames)
 		(at-most-one #t
 			     (lambda ()
-			       (exit:run-callbacks))))))
+			       (exit:run-callbacks)))
+		#t)))
     
     (exit:insert-callback
      (lambda ()

collects/framework/standard-menus-items.ss

@@ -24,13 +24,13 @@
 (define items
   (list (make-generic 'get-menu% '(lambda () menu%)
 		      '("The result of this method is used as the class for creating the result of these methods:"
-			"@mlink get-file-menu %"
+			"@ilink frame:standard-menus get-file-menu %"
 			", "
-			"@mlink get-edit-menu %"
+			"@ilink frame:standard-menus get-edit-menu %"
 			", "
-			"@mlink get-windows-menu %"
+			"@ilink frame:standard-menus get-windows-menu %"
 			", and"
-			"@mlink get-help-menu %"
+			"@ilink frame:standard-menus get-help-menu %"
 			". "
 			""
 			"@return : (derived-from \\iscmclass{menu})"
@@ -56,7 +56,7 @@
 			 (lambda () m))
 		      '("Returns the file menu"
 			"See also"
-			"@mlink get-menu\\%"
+			"@ilink frame:standard-menus get-menu\\%"
 			""
 			"@return : (instance (derived-from \\iscmclass{menu}))"))
 	(make-generic 'get-edit-menu
@@ -65,7 +65,7 @@
 		      
 		      '("Returns the edit menu"
 			"See also"
-			"@mlink get-menu\\%"
+			"@ilink frame:standard-menus get-menu\\%"
 			""
 			"@return : (instance (derived-from \\iscmclass{menu}))"))
 	(make-generic 'get-windows-menu
@@ -74,7 +74,7 @@
 		      
 		      '("Returns the windows menu"
 			"See also"
-			"@mlink get-menu\\%"
+			"@ilink frame:standard-menus get-menu\\%"
 			""
 			"@return : (instance (derived-from \\iscmclass{menu}))"))
 	(make-generic 'get-help-menu
@@ -83,7 +83,7 @@
 		      
 		      '("Returns the help menu"
 			"See also"
-			"@mlink get-menu\\%"
+			"@ilink frame:standard-menus get-menu\\%"
 			""
 			"@return : (instance (derived-from \\iscmclass{menu}))"))
 

collects/tests/framework/README

@@ -16,8 +16,8 @@ To run a test use:
    framework-test <test.ss> ...
 
 where or <test.ss> is the name of one of the tests
-below. Alternatively, pass no command-line arguments to run all of the
-tests.
+below. Alternatively, pass no command-line arguments to run the same
+test as last time.
 
 - load: |# load.ss #|
 
@@ -72,12 +72,12 @@ tests.
   | This tests the info frame. (ie that toolbar on the bottom of the
                                 screen)
 
-- group tests: |# group.ss #|
+- group tests: |# group-test.ss #|
 
   | make sure that mred:the-frame-group records frames correctly.
   | fake user input expected.
 
-- parenthesis toolkit: |# paren.ss #|
+- parenthesis toolkit: |# paren-test.ss #|
 
   | Test to be sure that parenthesis matching engine works
   | No fake user input expected.

collects/tests/framework/exit.ss

@@ -16,7 +16,7 @@
 	  (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t)
 				     (test:run-one (lambda () (exit:exit)))))
 	  (wait-for-frame "Warning")
-	  (send-sexp-to-mred '(test:button-push "Quit"))
+	  (wait-for-new-frame '(test:button-push "Quit"))
 	  'failed)))
 
 (test 'exit/prompt/no-twice
@@ -27,7 +27,7 @@
 	       (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t)
 					  (test:run-one (lambda () (exit:exit)))))
 	       (wait-for-frame "Warning")
-	       (send-sexp-to-mred `(test:button-push ,button)))])
+	       (wait-for-new-frame `(test:button-push ,button)))])
 	(lambda ()
 	  (exit/push-button "Cancel")
 	  (exit/push-button "Cancel")
@@ -35,6 +35,22 @@
 	    (exit/push-button "Quit")
 	    'failed))))
 
+(test 'exit/esc-cancel
+      (lambda (x) (and (eq? x 'passed)
+		       (not (mred-running?))))
+      (let ([exit/wait-for-warning
+	     (lambda ()
+	       (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t)
+					  (test:run-one (lambda () (exit:exit)))))
+	       (wait-for-frame "Warning"))])
+	(lambda ()
+	  (exit/wait-for-warning)
+	  (wait-for-new-frame `(test:close-top-level-window (get-top-level-focus-window)))
+	  (exit/wait-for-warning)
+	  (with-handlers ([eof-result? (lambda (x) 'passed)])
+	    (wait-for-new-frame '(test:button-push "Quit"))
+	    'failed))))
+
 (define tmp-file (build-path (find-system-path 'temp-dir) "framework-exit-test-suite"))
 (test 'exit-callback-called
       (lambda (x)

collects/tests/framework/frame.ss

@@ -1,13 +1,14 @@
 (define (test-creation name class-expression)
-  '(test
+  (test
    name
    (lambda (x) x)
    (lambda ()
      (send-sexp-to-mred
-      `(send (make-object ,class-expression "test") show #t))
+      `(begin (preferences:set 'framework:exit-when-no-frames #f)
+	      (send (make-object ,class-expression "test") show #t)))
      (wait-for-frame "test")
-     (send-sexp-to-mred
-      '(send (get-top-level-focus-window) show #f))
+     (queue-sexp-to-mred
+      '(send (get-top-level-focus-window) close))
      #t)))
 
 (test-creation
@@ -109,9 +110,10 @@
        (send-sexp-to-mred
 	`(begin (send (find-labelled-window "Full pathname") focus)
 		,(case (system-type)
-		   [(macos unix) `(test:keystroke #\a '(meta))]
+		   [(macos) `(test:keystroke #\a '(meta))]
+		   [(unix) `(test:keystroke #\a '(meta))]
 		   [(windows) `(test:keystroke #\a '(control))]
-		   [else (error "unknown system type")])
+		   [else (error "unknown system type: ~a" (system-type))])
 		(for-each test:keystroke
 			  (string->list ,tmp-file))
 		(test:keystroke #\return)))
@@ -123,10 +125,8 @@
 	    (test:close-top-level-window w)
 	    t))
 	(wait-for-frame "test open")
-	(send-sexp-to-mred
-	 `(begin
-	    (preferences:set 'framework:exit-when-no-frames #t)
-	    (test:close-top-level-window (get-top-level-focus-window)))))))))
+	(queue-sexp-to-mred
+	 `(send (get-top-level-focus-window) close)))))))
 
 (test-open "frame:editor open" 'frame:text%)
 (test-open "frame:editor open" 'frame:searchable%)

collects/tests/framework/group-test.ss

@@ -0,0 +1,138 @@
+(test
+ 'exit-off
+ (lambda (x) (not (equal? x "test")))
+ (lambda ()
+   (send-sexp-to-mred
+    '(begin (send (make-object frame:basic% "test") show #t)
+	    (preferences:set 'framework:exit-when-no-frames #f)))
+   (wait-for-frame "test")
+   (send-sexp-to-mred
+    `(begin (send (get-top-level-focus-window) close)
+	    (let ([f (get-top-level-focus-window)])
+	      (if f
+		  (send f get-label)
+		  #f))))))
+(test
+ 'exit-on
+ (lambda (x) (not (equal? x "test")))
+ (lambda ()
+   (send-sexp-to-mred
+    '(begin (send (make-object frame:basic% "test") show #t)
+	    (preferences:set 'framework:exit-when-no-frames #t)))
+   (wait-for-frame "test")
+   (send-sexp-to-mred
+    `(queue-callback (lambda () (send (get-top-level-focus-window) close))))
+   (wait-for-frame "Warning")
+   (send-sexp-to-mred
+    `(test:button-push "Cancel"))
+   (wait-for-frame "test")
+   (queue-sexp-to-mred
+    `(begin (preferences:set 'framework:exit-when-no-frames #f)
+	    (send (get-top-level-focus-window) close)
+	    (let ([f (get-top-level-focus-window)])
+	      (if f
+		  (send f get-label)
+		  #f))))))
+
+(test
+ 'one-frame-registered
+ (lambda (x) (equal? x (list "test")))
+ (lambda ()
+   (send-sexp-to-mred
+    `(send (make-object frame:basic% "test") show #t))
+   (wait-for-frame "test")
+   (send-sexp-to-mred
+    `(begin0
+      (map (lambda (x) (send x get-label)) (send (group:get-the-frame-group) get-frames))
+      (send (get-top-level-focus-window) close)))))
+
+(test
+ 'two-frames-registered
+ (lambda (x) (equal? x (list "test2" "test1")))
+ (lambda ()
+   (send-sexp-to-mred
+    '(send (make-object frame:basic% "test1") show #t))
+   (wait-for-frame "test1")
+   (send-sexp-to-mred
+    '(send (make-object frame:basic% "test2") show #t))
+   (wait-for-frame "test2")
+   (send-sexp-to-mred
+    `(begin0
+      (let ([frames (send (group:get-the-frame-group) get-frames)])
+	(for-each (lambda (x) (send x close)) frames)
+	(map (lambda (x) (send x get-label)) frames))))))
+
+(test
+ 'one-frame-unregistered
+ (lambda (x) (equal? x (list "test1")))
+ (lambda ()
+   (send-sexp-to-mred
+    '(send (make-object frame:basic% "test1") show #t))
+   (wait-for-frame "test1")
+   (send-sexp-to-mred
+    '(send (make-object frame:basic% "test2") show #t))
+   (wait-for-frame "test2")
+   (queue-sexp-to-mred
+    `(send (get-top-level-focus-window) close))
+   (send-sexp-to-mred
+    `(let ([frames (send (group:get-the-frame-group) get-frames)])
+       (for-each (lambda (x) (send x close)) frames)
+       (map (lambda (x) (send x get-label)) frames)))))
+
+(test
+ 'windows-menu
+ (lambda (x)
+   (equal? x (list "test")))
+ (lambda ()
+   (send-sexp-to-mred
+    '(let ([frame (make-object frame:basic% "test")])
+       (send frame show #t)))
+   (wait-for-frame "test")
+   (send-sexp-to-mred
+    '(begin0
+      (map
+       (lambda (x) (send x get-label))
+       (send (car (send (send (get-top-level-focus-window) get-menu-bar) get-items)) get-items))
+      (send (get-top-level-focus-window) close)))))
+
+(test
+ 'windows-menu-sorted1
+ (lambda (x)
+   (equal? x (list "aaa" "bbb")))
+ (lambda ()
+   (send-sexp-to-mred
+    '(let ([frame (make-object frame:basic% "aaa")])
+       (send frame show #t)))
+   (wait-for-frame "aaa")
+   (send-sexp-to-mred
+    '(let ([frame (make-object frame:basic% "bbb")])
+       (send frame show #t)))
+   (wait-for-frame "bbb")
+   (send-sexp-to-mred
+    `(let ([frames (send (group:get-the-frame-group) get-frames)])
+       (begin0
+	(map
+	 (lambda (x) (send x get-label))
+	 (send (car (send (send (car frames) get-menu-bar) get-items)) get-items))
+	(for-each (lambda (x) (send x close)) frames))))))
+
+(test
+ 'windows-menu-sorted2
+ (lambda (x)
+   (equal? x (list "aaa" "bbb")))
+ (lambda ()
+   (send-sexp-to-mred
+    '(let ([frame (make-object frame:basic% "bbb")])
+       (send frame show #t)))
+   (wait-for-frame "bbb")
+   (send-sexp-to-mred
+    '(let ([frame (make-object frame:basic% "aaa")])
+       (send frame show #t)))
+   (wait-for-frame "aaa")
+   (send-sexp-to-mred
+    `(let ([frames (send (group:get-the-frame-group) get-frames)])
+       (begin0
+	(map
+	 (lambda (x) (send x get-label))
+	 (send (car (send (send (car frames) get-menu-bar) get-items)) get-items))
+	(for-each (lambda (x) (send x close)) frames))))))

collects/tests/framework/main.ss

@@ -11,9 +11,15 @@
 (define-signature TestSuite^
   ((struct eof-result ())
    load-framework-automatically
-   shutdown-listener shutdown-mred mred-running? send-sexp-to-mred
+   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))
 
 (define-signature internal-TestSuite^
@@ -74,11 +80,11 @@
 	  (set! in-port in)
 	  (set! out-port out))
 	(when load-framework-automatically?
-	  (send-sexp-to-mred
+	  (queue-sexp-to-mred
 	   `(begin
 	      (require-library "framework.ss" "framework")
 	      (require-library "gui.ss" "tests" "utils")
-	      (test:run-interval 11))))))
+	      (test:run-interval 0))))))
 
     (define load-framework-automatically
       (case-lambda
@@ -109,6 +115,16 @@
 	    (not (eof-object? (peek-char in-port)))
 	    #t)))
 
+    (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 send-sexp-to-mred
       (lambda (sexp)
 	(let ([show-text 
@@ -193,17 +209,29 @@
 		  [(continue) (void)]
 		  [else (jump)])))))]))
 
-  (define (wait-for sexp)
+  (define (wait-for/wrapper wrapper sexp)
     (let ([timeout 10]
 	  [pause-time 1/2])
       (send-sexp-to-mred
-       `(let loop ([n ,(/ timeout pause-time)])
-	  (if (zero? n)
-	      (error 'wait-for
-		     ,(format "after ~a seconds, ~s didn't come true" timeout sexp))
-	      (unless ,sexp
-		(sleep ,pause-time)
-		(loop (- n 1))))))))
+       (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-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)])
@@ -234,15 +262,21 @@
 
     (with-handlers ([(lambda (x) #f)
 		     (lambda (x) (display (exn-message x)) (newline))])
-      (let ([all-files (map symbol->string (load-relative "README"))]
-	    [files-to-process null]
-	    [command-line-flags
-	     `((multi
-		[("-o" "--only")
-		 ,(lambda (flag _only-these-tests)
-		    (set! only-these-tests (cons (string->symbol _only-these-tests)
-						 (or only-these-tests null))))
-		 ("Only run test named <test-name>" "test-name")]))])
+      (let* ([all-files (map symbol->string (load-relative "README"))]
+	     [all? #f]
+	     [files-to-process null]
+	     [command-line-flags
+	      `((once-each
+		 [("-a" "--all")
+		  ,(lambda (flag)
+		     (set! all? #t))
+		  ("Run all of the tests")])
+		(multi
+		 [("-o" "--only")
+		  ,(lambda (flag _only-these-tests)
+		     (set! only-these-tests (cons (string->symbol _only-these-tests)
+						  (or only-these-tests null))))
+		  ("Only run test named <test-name>" "test-name")]))])
 	
 	(let* ([saved-command-line-file (build-path (collection-path "tests" "framework") "saved-command-line.ss")]
 	       [parsed-argv (if (equal? argv (vector))
@@ -255,7 +289,7 @@
 				argv)])
 	  (parse-command-line "framework-test" parsed-argv command-line-flags
 			      (lambda (collected . files)
-				(set! files-to-process (if (null? files) all-files files)))
+				(set! files-to-process (if (or all? (null? files)) all-files files)))
 			      `("Names of the tests; defaults to all tests"))
 	  (call-with-output-file saved-command-line-file
 	    (lambda (port)

collects/tests/framework/pasteboard.ss

@@ -10,10 +10,11 @@
 		      (lambda ()
 			,class)]))]
 	      [f (make-object % "test pasteboard")])
+	 (preferences:set 'framework:exit-when-no-frames #f)
 	 (send f show #t)))
       (wait-for-frame "test pasteboard")
-      (send-sexp-to-mred
-       `(send (get-top-level-focus-window) show #f)))))
+      (queue-sexp-to-mred
+       `(send (get-top-level-focus-window) close)))))
 
 (test-creation 'frame:editor%
 	       '(editor:basic-mixin pasteboard%)
@@ -23,7 +24,7 @@
 	       'pasteboard:basic-creation)
 
 (test-creation 'frame:editor%
-	       '(editor:file-mixin pasteboard:basic%)
+	       '(editor:file-mixin pasteboard:keymap%)
 	       'editor:file-mixin-creation)
 (test-creation 'frame:editor%
 	       'pasteboard:file%

collects/tests/framework/text.ss

@@ -8,6 +8,7 @@
 		   (override
 		    [get-editor% (lambda () ,class)]))]
 	      [f (make-object % "test text")])
+	 (preferences:set 'framework:exit-when-no-frames #f)
 	 (send f show #t)))
      (wait-for-frame "test text")
      (send-sexp-to-mred `(test:keystroke #\a))
@@ -15,8 +16,8 @@
      (send-sexp-to-mred
       `(begin (send (send (get-top-level-focus-window) get-editor) lock #t)
 	      (send (send (get-top-level-focus-window) get-editor) lock #f)))
-     (send-sexp-to-mred
-      `(send (get-top-level-focus-window) show #f)))))
+     (queue-sexp-to-mred
+      `(send (get-top-level-focus-window) close)))))
 
 
 (test-creation 'frame:text%
@@ -38,7 +39,7 @@
 	       'text:return-creation)
 
 (test-creation 'frame:text%
-	       '(editor:file-mixin text:basic%)
+	       '(editor:file-mixin text:keymap%)
 	       'editor:file-mixin-creation)
 (test-creation 'frame:text%
 	       'text:file%