From cd576ffb3c9a9da05dd525116f64c5af318b6697 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 29 Mar 2012 07:32:18 -0500 Subject: [PATCH] adjust the easter egg test suite so it can be loaded by Sam's lib to run all kinds of days. also fix a bug so that it properly resets the prefs back to the defaults (and thus has to explicitly set the language) --- collects/tests/drracket/easter-egg.rkt | 32 +++++ .../drracket/private/drracket-test-util.rkt | 7 +- .../tests/drracket/private/easter-egg-lib.rkt | 113 ++++++++++++++++++ collects/tests/drracket/splash.rkt | 90 -------------- 4 files changed, 148 insertions(+), 94 deletions(-) create mode 100644 collects/tests/drracket/easter-egg.rkt create mode 100644 collects/tests/drracket/private/easter-egg-lib.rkt delete mode 100644 collects/tests/drracket/splash.rkt diff --git a/collects/tests/drracket/easter-egg.rkt b/collects/tests/drracket/easter-egg.rkt new file mode 100644 index 0000000000..a947656b76 --- /dev/null +++ b/collects/tests/drracket/easter-egg.rkt @@ -0,0 +1,32 @@ +#lang racket/base +(require racket/class + racket/date + "private/easter-egg-lib.rkt") + +(define (run-tests) + (start-up-on-day 2 14 "Valentine's Day") + (start-up-on-day 3 2 "Texas Indepenence Day") + (start-up-on-day 3 26 "Prince Kuhio Day") + (start-up-on-day 6 11 "King Kamehameha Day") + (start-up-on-day 7 30 "Eli's birthday") + (start-up-on-day 10 29 "Matthias's birthday") + (start-up-on-day 10 31 "Halloween") + (start-up-on-day 11 1 "Matthew's birthday") + (start-up-on-day 12 25 "Christmas") + + (define now (current-seconds)) + (define week-day (date-week-day (seconds->date now))) + (define seconds-in-a-day (* 60 60 24)) + (define sunday-secs (+ (* (- 7 week-day) seconds-in-a-day) now)) + (define sunday (seconds->date sunday-secs)) + (define monday (seconds->date (+ sunday-secs seconds-in-a-day))) + (start-up-on-day (date-month sunday) + (date-day sunday) + "Weekend") + (start-up-on-day (date-month monday) + (date-day monday) + "Weekday")) + + + +(run-tests) diff --git a/collects/tests/drracket/private/drracket-test-util.rkt b/collects/tests/drracket/private/drracket-test-util.rkt index 37d8f60e4c..e72657c146 100644 --- a/collects/tests/drracket/private/drracket-test-util.rkt +++ b/collects/tests/drracket/private/drracket-test-util.rkt @@ -650,12 +650,11 @@ ;; exports during the call to 'run-test' is safe (namespace-require 'framework) - (use-hash-for-prefs (dynamic-require 'framework 'preferences:low-level-get-preference) - (dynamic-require 'framework 'preferences:low-level-put-preferences) - (dynamic-require 'framework 'preferences:restore-defaults)) - (queue-callback (λ () + (use-hash-for-prefs (dynamic-require 'framework 'preferences:low-level-get-preference) + (dynamic-require 'framework 'preferences:low-level-put-preferences) + (dynamic-require 'framework 'preferences:restore-defaults)) (dynamic-require 'drracket #f) (thread (λ () (run-test) diff --git a/collects/tests/drracket/private/easter-egg-lib.rkt b/collects/tests/drracket/private/easter-egg-lib.rkt new file mode 100644 index 0000000000..5c7c1f088d --- /dev/null +++ b/collects/tests/drracket/private/easter-egg-lib.rkt @@ -0,0 +1,113 @@ +#lang racket/base + +(require (only-in "drracket-test-util.rkt" + fire-up-separate-drracket-and-run-tests + queue-callback/res) + racket/date + racket/class + racket/contract) + +(provide + (contract-out + [start-up-on-day + (-> (and/c integer? (between/c 0 12)) + (and/c integer? (between/c 0 31)) + string? + void?)] + [start-up-and-check-car (-> void?)])) + +(define (start-up-on-day month day what) + (define the-seconds (find-seconds 1 0 0 + day month + (date-year (seconds->date (current-seconds))))) + (printf "trying ~a, ~a/~a PLTDREASTERSECONDS=~a\n" what month day the-seconds) + (unless (putenv "PLTDREASTERSECONDS" (number->string the-seconds)) + (error 'splash.rkt "putenv failed")) + (start-up-and-check-car)) + +(define (start-up-and-check-car) + (fire-up-separate-drracket-and-run-tests + (λ () + + (define-syntax-rule + (define/fw x) + (define x (dynamic-require 'framework 'x))) + + (define/fw test:keystroke) + (define/fw test:run-one) + (define/fw test:use-focus-table) + (define/fw test:get-active-top-level-window) + (define/fw test:menu-select) + (define/fw test:set-radio-box-item!) + (define/fw test:button-push) + (define current-eventspace (dynamic-require 'racket/gui/base 'current-eventspace)) + + (define (main) + (queue-callback/res (λ () (test:use-focus-table #t))) + (test:use-focus-table #t) + (define drr-frame (wait-for-drracket-frame)) + (set-module-language! drr-frame) + (queue-callback/res (λ () (send (send (send drr-frame get-definitions-text) get-canvas) focus))) + (for ([x (in-string "(car 'x)")]) + (test:keystroke x)) + (let ([button (queue-callback/res (λ () (send drr-frame get-execute-button)))]) + (test:run-one (lambda () (send button command)))) + (wait-for-run-to-finish drr-frame) + (define res + (queue-callback/res (λ () (send (send drr-frame get-interactions-text) get-text)))) + (unless (regexp-match (regexp-quote "car: expects argument of type ; given: 'x") + res) + (eprintf "splash.rkt: interactions looks wrong; got: ~s\n" res))) + + (define (set-module-language! drr-frame) + (test:menu-select "Language" "Choose Language...") + (define language-dialog (wait-for-new-frame drr-frame)) + (test:set-radio-box-item! #rx"Use the language declared in the source") + + (with-handlers ([exn:fail? (lambda (x) (void))]) + (test:button-push "Show Details")) + + (test:button-push "Revert to Language Defaults") + + (test:button-push "OK") + (define new-frame (wait-for-new-frame language-dialog)) + (unless (eq? new-frame drr-frame) + (error 'set-module-level! + "didn't get drracket frame back, got: ~s (drr-frame ~s)\n" + new-frame + drr-frame))) + + (define (wait-for-run-to-finish drr-frame) + (define (run-finished) + (send (send drr-frame get-execute-button) is-enabled?)) + (wait-for-something run-finished)) + + (define (wait-for-drracket-frame) + (define (drracket-frame-frontmost) + (define active (test:get-active-top-level-window)) + (and active + (method-in-interface? 'get-execute-button (object-interface active)) + active)) + (wait-for-something drracket-frame-frontmost)) + + (define (wait-for-new-frame old-frame) + (wait-for-something + (λ () + (define active (test:get-active-top-level-window)) + (and active + (not (eq? active old-frame)) + active)))) + + (define (wait-for-something thing?) + (define total-time-to-wait 20) ;; in seconds + (define time-to-wait-in-one-iteration 1/10) ;; also in seconds + (let loop ([n (/ total-time-to-wait time-to-wait-in-one-iteration)]) + (cond + [(thing?) => values] + [(zero? n) + (error 'wait-for-something "~s didn't happen" thing?)] + [else + (sleep time-to-wait-in-one-iteration) + (loop (- n 1))]))) + + (main)))) diff --git a/collects/tests/drracket/splash.rkt b/collects/tests/drracket/splash.rkt deleted file mode 100644 index e5deef4dd5..0000000000 --- a/collects/tests/drracket/splash.rkt +++ /dev/null @@ -1,90 +0,0 @@ -#lang racket/base -(require (only-in "private/drracket-test-util.rkt" - fire-up-separate-drracket-and-run-tests - queue-callback/res) - racket/class - racket/date) - -(define (run-tests) - (start-up-on-day 2 14 "Valentine's Day") - (start-up-on-day 3 2 "Texas Indepenence Day") - (start-up-on-day 3 26 "Prince Kuhio Day") - (start-up-on-day 6 11 "King Kamehameha Day") - (start-up-on-day 7 30 "Eli's birthday") - (start-up-on-day 10 29 "Matthias's birthday") - (start-up-on-day 10 31 "Halloween") - (start-up-on-day 11 1 "Matthew's birthday") - (start-up-on-day 12 25 "Christmas") - - (define now (current-seconds)) - (define week-day (date-week-day (seconds->date now))) - (define seconds-in-a-day (* 60 60 24)) - (define sunday-secs (+ (* (- 7 week-day) seconds-in-a-day) now)) - (define sunday (seconds->date sunday-secs)) - (define monday (seconds->date (+ sunday-secs seconds-in-a-day))) - (start-up-on-day (date-month sunday) - (date-day sunday) - "Weekend") - (start-up-on-day (date-month monday) - (date-day monday) - "Weekday")) - -(define (start-up-on-day month day what) - (define the-seconds (find-seconds 1 0 0 - day month - (date-year (seconds->date (current-seconds))))) - (printf "trying ~a, ~a/~a PLTDREASTERSECONDS=~a\n" what month day the-seconds) - (unless (putenv "PLTDREASTERSECONDS" (number->string the-seconds)) - (error 'splash.rkt "putenv failed")) - (fire-up-separate-drracket-and-run-tests - (λ () - - (define test:keystroke (dynamic-require 'framework 'test:keystroke)) - (define test:run-one (dynamic-require 'framework 'test:run-one)) - (define test:use-focus-table (dynamic-require 'framework 'test:use-focus-table)) - (define test:get-active-top-level-window (dynamic-require 'framework 'test:get-active-top-level-window)) - (define current-eventspace (dynamic-require 'racket/gui/base 'current-eventspace)) - - (define (wait-for-run-to-finish drr-frame) - (define (run-finished) - (send (send drr-frame get-execute-button) is-enabled?)) - (wait-for-something run-finished)) - - (define (wait-for-drracket-frame) - (define (drracket-frame-frontmost) - (define active (test:get-active-top-level-window)) - (and active - (method-in-interface? 'get-execute-button (object-interface active)) - active)) - (wait-for-something drracket-frame-frontmost)) - - (define (wait-for-something thing?) - (define total-time-to-wait 20) ;; in seconds - (define time-to-wait-in-one-iteration 1/10) ;; also in seconds - (let loop ([n (/ total-time-to-wait time-to-wait-in-one-iteration)]) - (cond - [(thing?) => values] - [(zero? n) - (error 'wait-for-something "~s didn't happen" thing?)] - [else - (sleep time-to-wait-in-one-iteration) - (loop (- n 1))]))) - - (queue-callback/res (λ () (test:use-focus-table #t))) - (test:use-focus-table #t) - (define drr-frame (wait-for-drracket-frame)) - (queue-callback/res (λ () (send (send (send drr-frame get-definitions-text) get-canvas) focus))) - (for ([x (in-string "(car 'x)")]) - (test:keystroke x)) - (let ([button (queue-callback/res (λ () (send drr-frame get-execute-button)))]) - (test:run-one (lambda () (send button command)))) - (wait-for-run-to-finish drr-frame) - (define res - (queue-callback/res (λ () (send (send drr-frame get-interactions-text) get-text)))) - (unless (regexp-match (regexp-quote "car: expects argument of type ; given: 'x") - res) - (eprintf "splash.rkt: testing on ~a ~a, interactions looks wrong; got: ~s\n" - month day - res))))) - -(run-tests)