suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added a test suite for DrRacket that checks to make sure the Dear Dr

Browse Source 
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)
This commit is contained in:
Robby Findler 2012-03-26 15:42:36 -05:00
parent b640b6b41c
commit 617df05ef7
6 changed files with 184 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/drracket/private/drracket-normal.rkt
View File

@ -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))

38
collects/framework/private/bday.rkt
View File

@ -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=

5
collects/framework/splash.rkt
View File

@ -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)

6
collects/scribblings/drracket/extending.scrbl
View File

@ -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.}
]

84
collects/tests/drracket/private/drracket-test-util.rkt
View File

@ -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")))

90
collects/tests/drracket/splash.rkt Normal file
View File

@ -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 <pair>; given: 'x")
res)
(eprintf "splash.rkt: testing on ~a ~a, interactions looks wrong; got: ~s\n"
month day
res)))))
(run-tests)