first attempt at randomly clicking on drscheme into drdr

svn: r17243

collects/tests/drscheme/randomly-click-language-dialog.ss

@@ -0,0 +1,3 @@
+#lang scheme
+(require "randomly-click.ss")
+(go 'language-dialog)

collects/tests/drscheme/randomly-click-preferences.ss

@@ -0,0 +1,3 @@
+#lang scheme
+(require "randomly-click.ss")
+(go 'preferences-dialog)

collects/tests/drscheme/randomly-click.ss

@@ -0,0 +1,172 @@
+#lang scheme/gui
+(require framework)
+(provide go)
+
+(define numButtonsToPush 200)
+
+;;find-all-actions: area -> (listof (-> void))
+(define (find-all-actions area)
+  (cond
+    [(is-a? area area-container<%>)
+     (apply append (map find-all-actions (send area get-children)))]
+    [(and (is-a? area button%)
+          (send area is-enabled?)
+          (send area is-shown?))
+     (list (case-lambda
+             [(x) (format "button ~s" (send area get-label))]
+             [() (test:button-push area)]))]
+    [(and (is-a? area check-box%)
+          (send area is-enabled?))
+     (let ([func
+            (λ (which-way)
+              (case-lambda 
+                [(x) (format "checkbox ~s" (send area get-label))]
+                [() (test:set-check-box! area which-way)]))])
+       (list (func #t) (func #f)))]
+    [(and (is-a? area radio-box%)
+          (send area is-enabled?))
+     (for/list ([i (in-range 0 (send area get-number))])
+       (case-lambda
+         [(x) (format "radiobox, item ~s" (send area get-item-label i))]
+         [() (test:set-radio-box! area i)]))]
+    [else '()]))
+
+;;find-random-button: area -> random element of the buttons in area
+;;return #f if there is no buttons in area
+(define (find-random-action area)
+  (define buttons (find-all-actions area))
+  (cond
+    ;;Area with no buttons
+    [(null? buttons) #f]
+    [else (list-ref buttons (random (length buttons)))]))
+
+;; Trace the path to the area back to a base-frame
+(define (trace-area area base-frame)
+  (cond
+    [(eq? area base-frame)
+     (list base-frame)]
+    [else
+     (append (trace-area (send area get-parent) base-frame) (list area))]
+    ))
+
+;;toy print-label function
+(define (print-label area)
+  (cond
+    [(is-a? area tab-panel%)
+     ;(send area get-item-label (send area get-selection))]
+     (send area get-item-label 0)]
+    [(is-a? area vertical-panel%)
+     "Vert-Panel"]
+    [(is-a? area horizontal-panel%)
+     "Hort-Panel"]
+    [(is-a? area vertical-pane%)
+     "Vert-Pane"]
+    [(is-a? area horizontal-pane%)
+     "Hort-Pane"]
+    [else
+     (send area get-label)]))
+
+(define (g open-dialog)
+  (thread
+   (λ ()
+     (let ((base-window (get-top-level-focus-window)))
+       (open-dialog)
+       (wait-for-different-frame base-window)
+       (let loop ([n numButtonsToPush]
+                  [actions '()])
+         (cond
+           [(zero? n) 
+            (printf "\n")
+            (exit 0)]
+           [else
+            
+            (printf "~a " n)
+            (when (= 1 (modulo n 10)) (printf "\n"))
+            (flush-output)
+         
+            (let ((window (get-top-level-focus-window)))
+              (cond
+                ;; Back to base-window is not interesting, Reopen
+                [(eq? base-window window)
+                 (open-dialog)
+                 (wait-for-different-frame base-window)
+                 (loop (- n 1) actions)]
+                
+                ;; get-top-level-focus-window returns #f may imply window not in current eventspace
+                ;; but it also might just mean we didn't look into subeventspaces(?)
+                ;; or that we need to wait for something to happen in the GUI(?)
+                [(eq? window #f)
+                 (sleep .1)
+                 (loop (- n 1) actions)]
+                
+                [else
+                 ;; print out the button before the button is pushed
+                 ;; Using the toy print-label function
+                 ;; because some of the parents may not be sent with get-label e.g. vertical-pane%
+                 ;(print (map print-label (trace-area button window)))
+                 (let ([action (find-random-action window)])
+                   (cond
+                     [action
+                      (with-handlers ((exn:fail? (λ (x) 
+                                                   (fprintf (current-error-port)
+                                                            "\nExecution fail: Bug? transcript of ~a clicking follows\n"
+                                                            (send window get-label))
+                                                   (apply show-log (cons action actions))
+                                                   (raise x))))
+                        (action))
+                      (loop (- n 1) (cons action actions))]
+                     [else
+                      (fprintf (current-error-port) "\nExists/Meets window with no button: Bug? -> Reopen Dialog")
+                      (open-dialog)
+                      (loop n actions)]))]))]))))))
+
+(define (show-log . actions)
+  (for ((action (in-list actions)))
+    (fprintf (current-error-port) 
+             "   ~a\n" 
+             (action 'ignored))))
+
+;; the splash screen is in a separate eventspace so wont' show up.
+(define (wait-for-first-frame)
+  (let loop ()
+    (let ([tlws (get-top-level-windows)])
+      (cond
+        [(null? tlws)
+         (sleep 1/10)
+         (loop)]
+        [else (car tlws)]))))
+
+
+(define (wait-for-different-frame win)
+  (let loop ([n 1000])
+    (cond
+      [(zero? n)
+       (error 'wait-for-different-frame "never got that new window, only this one: ~s" win)]
+      [else
+       (let ([tlw (get-top-level-focus-window)])
+         (when (eq? win tlw)
+           (sleep 1/10)
+           (loop (- n 1))))])))
+
+(define orig-display-handler (error-display-handler))
+
+(define (go which-dialog)
+  (dynamic-require 'drscheme #f)
+  
+  ;; reset the uncaught exception handler to be sure we kill everything (drscheme sets it)
+  (uncaught-exception-handler
+   (λ (x)
+     (if (exn? x)
+         (orig-display-handler (exn-message x) x)
+         (fprintf (current-error-port) "uncaught exception ~s\n" x))
+     (exit 1)))
+  
+  (void
+   (thread
+    (λ ()
+      (define drs (wait-for-first-frame))
+      (case which-dialog
+        [(language-dialog)
+         (g (λ () (test:menu-select "Language" "Choose Language...")))]
+        [(preferences-dialog)
+         (g (λ () (preferences:show-dialog)))])))))