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

add check for adjacent separators into tests

Browse Source
This commit is contained in:
Robby Findler 2012-08-07 12:51:52 -05:00
parent 2256ca39ea
commit 4a19ab40e8
1 changed files with 116 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

162
collects/tests/drracket/no-write-and-frame-leak.rkt
View File

@ -1,63 +1,123 @@
#lang racket #lang racket
#|
This test checks:
- if opening frames/tabs leaks,
- if DrRacket writes to the filesystem during startup or
while opening tabs/frames
- if there are any adjacent separators in the menus
|#
(require "private/drracket-test-util.rkt" (require "private/drracket-test-util.rkt"
racket/gui/base
framework) framework)
(parameterize ([current-security-guard (define (main)
(make-security-guard (parameterize ([current-security-guard
(current-security-guard) (make-security-guard
(λ (who pth what) (current-security-guard)
(when (member 'write what) (λ (who pth what)
(error who "Writing to the file system is not allowed")) (when (member 'write what)
(when (member 'delete what) (error who "Writing to the file system is not allowed"))
(error who "Deleting files is not allowed"))) (when (member 'delete what)
void (error who "Deleting files is not allowed")))
void)]) void
(fire-up-drracket-and-run-tests void)])
(λ () (fire-up-drracket-and-run-tests
(define drs-frame1 (wait-for-drracket-frame)) (λ ()
(sync (system-idle-evt)) (define drs-frame1 (wait-for-drracket-frame))
(for ([tries (in-range 3)])
(test:menu-select "File" "New Tab")
(sync (system-idle-evt)) (sync (system-idle-evt))
(define drs-tabb (make-weak-box (send drs-frame1 get-current-tab))) (check-menus drs-frame1)
(define tab-nsb (make-weak-box (send (send (send drs-frame1 get-current-tab) get-ints) get-user-namespace)))
(test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab")) (for ([tries (in-range 3)])
(sync (system-idle-evt)) (test:menu-select "File" "New Tab")
(sync (system-idle-evt))
(test:menu-select "File" "New") (define drs-tabb (make-weak-box (send drs-frame1 get-current-tab)))
(sync (system-idle-evt)) (define tab-nsb (make-weak-box (send (send (send drs-frame1 get-current-tab) get-ints) get-user-namespace)))
(define drs-frame2b (make-weak-box (wait-for-new-frame drs-frame1))) (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab"))
(define frame2-nsb (make-weak-box (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-ints) get-user-namespace))) (sync (system-idle-evt))
(queue-callback/res (test:menu-select "File" "New")
(λ () (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-defs) load-file (sync (system-idle-evt))
(collection-file-path "unit.rkt" "drracket" "private"))))
(sleep 2)
(sync (system-idle-evt))
(test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Window")) (define drs-frame2b (make-weak-box (wait-for-new-frame drs-frame1)))
(sync (system-idle-evt)) (define frame2-nsb (make-weak-box (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-ints) get-user-namespace)))
(let loop ([n 30]) (queue-callback/res
(cond (λ () (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-defs) load-file
[(zero? n) (collection-file-path "unit.rkt" "drracket" "private"))))
(when (weak-box-value drs-tabb) (sleep 2)
(eprintf "frame leak!\n")) (sync (system-idle-evt))
(when (weak-box-value drs-frame2b)
(eprintf "tab leak!\n")) (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Window"))
(when (weak-box-value tab-nsb) (sync (system-idle-evt))
(eprintf "tab namespace leak!\n"))
(when (weak-box-value frame2-nsb) (let loop ([n 30])
(eprintf "frame namespace leak!\n"))] (cond
[else [(zero? n)
(collect-garbage) (sync (system-idle-evt)) (when (weak-box-value drs-tabb)
(when (ormap weak-box-value (eprintf "frame leak!\n"))
(list drs-tabb (when (weak-box-value drs-frame2b)
tab-nsb (eprintf "tab leak!\n"))
drs-frame2b (when (weak-box-value tab-nsb)
frame2-nsb)) (eprintf "tab namespace leak!\n"))
(loop (- n 1)))])))))) (when (weak-box-value frame2-nsb)
(eprintf "frame namespace leak!\n"))]
[else
(collect-garbage) (sync (system-idle-evt))
(when (ormap weak-box-value
(list drs-tabb
tab-nsb
drs-frame2b
frame2-nsb))
(loop (- n 1)))])))))))
(define (check-menus frame)
(define (process-container container)
(define sub-items (send container get-items))
(unless (null? sub-items)
(when (is-a? (car sub-items) menu-item-container<%>)
(process-container (car sub-items)))
(define printed? #f)
(for ([prev-item (in-list sub-items)]
[item (in-list (cdr sub-items))])
(when (and (is-a? prev-item separator-menu-item%)
(is-a? item separator-menu-item%)
(not printed?))
(set! printed? #t)
(eprintf "found two adjacent separator items in: ~s:\n" (get-names container))
(for ([item (in-list sub-items)])
(eprintf " ~a\n" (get-lab item)))
(eprintf "\n"))
(when (is-a? item menu-item-container<%>)
(process-container item)))))
(define (get-lab item)
(cond
[(is-a? item labelled-menu-item<%>)
(send item get-label)]
[(is-a? item separator-menu-item%)
"---------"]
[else #f]))
(define (get-names item)
(let loop ([item item])
(cond
[(is-a? item menu-item<%>)
(cons (get-lab item)
(loop (send item get-parent)))]
[else
'()])))
(process-container (send frame get-menu-bar)))
(main)