From 617df05ef7d43c04cfaf6978c52619e1865a4812 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 26 Mar 2012 15:42:36 -0500 Subject: [PATCH] added a test suite for DrRacket that checks to make sure the Dear Dr starts up on all of the days that have easter eggs (well, except 7/2, since that one is hard to interpose on and hasn't changed in a long time) --- collects/drracket/private/drracket-normal.rkt | 27 +++--- collects/framework/private/bday.rkt | 38 ++------ collects/framework/splash.rkt | 5 +- collects/scribblings/drracket/extending.scrbl | 6 ++ .../drracket/private/drracket-test-util.rkt | 84 +++++++++++++---- collects/tests/drracket/splash.rkt | 90 +++++++++++++++++++ 6 files changed, 184 insertions(+), 66 deletions(-) create mode 100644 collects/tests/drracket/splash.rkt diff --git a/collects/drracket/private/drracket-normal.rkt b/collects/drracket/private/drracket-normal.rkt index f3c0e36faa..45008d4ff1 100644 --- a/collects/drracket/private/drracket-normal.rkt +++ b/collects/drracket/private/drracket-normal.rkt @@ -15,19 +15,23 @@ (define files-to-open (command-line #:args filenames filenames)) +(define the-date (seconds->date + (let ([ssec (getenv "PLTDREASTERSECONDS")]) + (if ssec + (string->number ssec) + (current-seconds))))) + ;; updates the command-line-arguments with only the files ;; to open. See also main.rkt. (current-command-line-arguments (apply vector files-to-open)) (define (currently-the-weekend?) - (define date (seconds->date (current-seconds))) - (define dow (date-week-day date)) + (define dow (date-week-day the-date)) (or (= dow 6) (= dow 0))) (define (valentines-day?) - (define date (seconds->date (current-seconds))) - (and (= 2 (date-month date)) - (= 14 (date-day date)))) + (and (= 2 (date-month the-date)) + (= 14 (date-day the-date)))) (define (current-icon-state) (cond @@ -36,16 +40,14 @@ [else 'normal])) (define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween?) - (let* ([date (seconds->date (current-seconds))] - [month (date-month date)] - [day (date-day date)] - [dow (date-week-day date)]) + (let* ([month (date-month the-date)] + [day (date-day the-date)] + [dow (date-week-day the-date)]) (values (and (= 3 month) (= 2 day)) (and (= 3 month) (= 26 day)) (and (= 6 month) (= 11 day)) (and (= 10 month) (= 31 day))))) - (define special-state #f) (define (icons-bitmap name) @@ -95,7 +97,7 @@ (when (and (eq? ch #\q) (send evt get-control-down)) (exit)) - (when (char? ch) + (when (and the-splash-bitmap (char? ch)) ;; as soon as something is typed, load the bitmaps (load-magic-images) (add-key-code ch) @@ -134,8 +136,7 @@ [else normal-bitmap-spec])) (define the-splash-bitmap (and (path? the-bitmap-spec) (read-bitmap the-bitmap-spec))) -(when the-splash-bitmap - (set-splash-char-observer drracket-splash-char-observer)) +(set-splash-char-observer drracket-splash-char-observer) (when (eq? (system-type) 'macosx) (define initial-state (current-icon-state)) diff --git a/collects/framework/private/bday.rkt b/collects/framework/private/bday.rkt index 7f6e68903b..a674f74c8f 100644 --- a/collects/framework/private/bday.rkt +++ b/collects/framework/private/bday.rkt @@ -1,34 +1,6 @@ #lang s-exp framework/private/decode - - TY+9Ds - IwDIT3P - MWN9hCJA - hIwAA - +CGN - rGFR - UkRW - lA4u - 1JaF - K6ne - /zz1n - R0w/v - 3gis73R - j6s8Zto - jxn oU0 - k2Cl yEjX - OwFR cmBh - mBVA Dwmg - i6lD RKO0 - gzOj Pk1l - +/Je XNDZ - Zr6m iThT - OwM6 glKb - toML NyTJ - sPz3 05XJ - jZd4 kaCE - iot+ UbDD - ZhUb Cp/f - yLxa YX1Y - 8vnh zCug - WvD5 +7J/C - +wj/ \wI=;; +bZFPT8MwDMXv/RRPOzmHSCsgAQeGEOsNAVp3QxzaxR0VJEVJNolvT5Kl3fiT04t/z45jF/Rp +h32vGNp2slXN1y30KNx7FtwehCgKUtz1hkEUI9BQQhQAfbAHvajGB+R4Mxjl5CJdA/1xstUF +F2jLns0es+eH9XJV3dXralVX90+Py3omXsXv1JDcd4iZf0miztvebOXC7HTLNjn/KZKsm521 +bLzMzYpw8oPUGAW6AcX2pR6Mf0OUAloc4/H3h6iKucfJjMMKhdKIcInzeTCMfBpv5uUcZ9en +fFpE5iVQnvBpK2P9C+Aq8G8= diff --git a/collects/framework/splash.rkt b/collects/framework/splash.rkt index 65e22378f3..797e7e677a 100644 --- a/collects/framework/splash.rkt +++ b/collects/framework/splash.rkt @@ -240,7 +240,10 @@ (set! splash-load-handler (λ (old-load f expected) (old-load f expected)))) (define funny? - (let ([date (seconds->date (current-seconds))]) + (let ([date (seconds->date (let ([ssec (getenv "PLTDREASTERSECONDS")]) + (if ssec + (string->number ssec) + (current-seconds))))]) (and (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (collection-path "icons") #t) diff --git a/collects/scribblings/drracket/extending.scrbl b/collects/scribblings/drracket/extending.scrbl index 2d44a282bb..0070434833 100644 --- a/collects/scribblings/drracket/extending.scrbl +++ b/collects/scribblings/drracket/extending.scrbl @@ -176,4 +176,10 @@ Several environment variables can affect DrRacket's behavior: set, DrRacket will print out that it is set, and will print when the index is started loading and when it finishes loading.} + @item{@indexed-envvar{PLTDREASTERSECONDS} : When this environment variable + is set, DrRacket pretends that the result of @racket[current-seconds] + is actually this environment variable's value, for the purposes + of easter eggs. For example, setting it to 1339390801 would simulate + King Kamehameha day 2012 and show the corresponding easter egg splash + screen.} ] diff --git a/collects/tests/drracket/private/drracket-test-util.rkt b/collects/tests/drracket/private/drracket-test-util.rkt index 3dd76c4cb2..be0c1a8e5f 100644 --- a/collects/tests/drracket/private/drracket-test-util.rkt +++ b/collects/tests/drracket/private/drracket-test-util.rkt @@ -13,6 +13,7 @@ (provide queue-callback/res fire-up-drracket-and-run-tests + fire-up-separate-drracket-and-run-tests save-drracket-window-as do-execute test-util-error @@ -168,7 +169,7 @@ (let ([button (queue-callback/res (λ () (send frame get-execute-button)))]) (fw:test:run-one (lambda () (send button command))) (when wait-for-finish? - (wait-for-computation frame)))])) + (wait-for-computation frame)))])) (define (verify-drracket-frame-frontmost function-name frame) (on-eventspace-handler-thread 'verify-drracket-frame-frontmost) @@ -603,25 +604,12 @@ (define (fire-up-drracket-and-run-tests #:use-focus-table? [use-focus-table? #t] run-test) (on-eventspace-handler-thread 'fire-up-drracket-and-run-tests) (let () - ;; change the preferences system so that it doesn't write to - ;; a file; partly to avoid problems of concurrency in drdr - ;; but also to make the test suite easier for everyone to run. - (let ([prefs-table (make-hash)]) - (fw:preferences:low-level-put-preferences - (lambda (names vals) - (for-each (lambda (name val) (hash-set! prefs-table name val)) - names vals))) - (fw:preferences:low-level-get-preference - (lambda (name [fail (lambda () #f)]) - (hash-ref prefs-table name fail)))) - + (use-hash-for-prefs fw:preferences:low-level-put-preferences + fw:preferences:low-level-get-preference + fw:preferences:restore-defaults) + (parameterize ([current-command-line-arguments #()]) - (dynamic-require 'drscheme #f)) - - ;; set all preferences to their defaults (some pref values may have - ;; been read by this point, but hopefully that won't affect much - ;; of the startup of drracket) - (fw:preferences:restore-defaults) + (dynamic-require 'drracket #f)) (fw:test:use-focus-table use-focus-table?) @@ -636,7 +624,65 @@ (run-test) (exit))) (yield (make-semaphore 0)))) + + ;; fire-up-separate-drracket-and-run-tests : (-> any) -> any + ;; creates a separate custodian, eventspace, namespace, etc to + ;; start up a new DrRacket. This has the advantage over fire-up-drracket-and-run-tests + ;; that a single test suite can start up DrRacket multiple times, but it has the + ;; disadvantage that there is little sharing between the test suite implementation code and + ;; DrRacket, so writing the testing code is more painful + ;; + ;; the only things shared are mred/mred (and its dependencies). + (define (fire-up-separate-drracket-and-run-tests run-test) + (define c (make-custodian)) + (define s (make-semaphore 0)) + (define orig-ns (current-namespace)) + (parameterize ([current-custodian c]) + (parameterize ([exit-handler (λ (v) + (semaphore-post s) + (custodian-shutdown-all c))] + [current-namespace (make-empty-namespace)] + [current-command-line-arguments #()]) + (parameterize ([current-eventspace (make-eventspace)]) + (namespace-attach-module orig-ns 'mred/mred) + + ;; do this now so that dynamically requiring framework + ;; 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 + (λ () + (dynamic-require 'drracket #f) + (thread (λ () + (run-test) + (exit))) + (yield (make-semaphore 0))))))) + (semaphore-wait s)) + (define (use-hash-for-prefs preferences:low-level-get-preference + preferences:low-level-put-preferences + preferences:restore-defaults) + ;; change the preferences system so that it doesn't write to + ;; a file; partly to avoid problems of concurrency in drdr + ;; but also to make the test suite easier for everyone to run. + (let ([prefs-table (make-hash)]) + (preferences:low-level-put-preferences + (lambda (names vals) + (for-each (lambda (name val) (hash-set! prefs-table name val)) + names vals))) + (preferences:low-level-get-preference + (lambda (name [fail (lambda () #f)]) + (hash-ref prefs-table name fail))) + + ;; set all preferences to their defaults (some pref values may have + ;; been read by this point, but hopefully that won't affect the + ;; startup of drracket) + (preferences:restore-defaults))) + (define (not-on-eventspace-handler-thread fn) (when (eq? (current-thread) (eventspace-handler-thread (current-eventspace))) (error fn "expected to be run on some thread other than the eventspace handler thread"))) diff --git a/collects/tests/drracket/splash.rkt b/collects/tests/drracket/splash.rkt new file mode 100644 index 0000000000..e5deef4dd5 --- /dev/null +++ b/collects/tests/drracket/splash.rkt @@ -0,0 +1,90 @@ +#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)