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

switching to log intereception to avoid message queue buildup

Browse Source
This commit is contained in:
Spencer Florence 2015-08-07 16:05:01 -05:00
parent c44bbdeeba
commit 66885e5758
2 changed files with 65 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
cover/cover.rkt
View File

@ -53,28 +53,31 @@ information is converted to a usable form by `get-test-coverage`.
;; returns true if no tests reported as failed, and no files errored.
(define (test-files! #:submod [submod-name 'test] #:env [env (current-cover-environment)] . files)
(parameterize ([current-cover-environment env])
(define abs
(for/list ([p (in-list files)])
(if (list? p)
(cons (->absolute (car p)) (cdr p))
(->absolute p))))
(define abs-names
(for/list ([p (in-list abs)])
(match p
[(cons p _) p]
[_ p])))
(define cover-load/use-compiled (make-cover-load/use-compiled abs-names))
(define tests-failed
(parameterize* ([current-load/use-compiled cover-load/use-compiled]
[current-namespace (get-namespace)])
(for ([f (in-list abs-names)])
(vprintf "forcing compilation of ~a" f)
(compile-file f))
(for/fold ([tests-failed #f]) ([f (in-list abs)])
(define failed? (handle-file f submod-name))
(or failed? tests-failed))))
(vprintf "ran ~s\n" files)
(not tests-failed)))
(with-intercepted-logging/receiver (cover-receiver (get-raw-coverage-map))
(lambda ()
(define abs
(for/list ([p (in-list files)])
(if (list? p)
(cons (->absolute (car p)) (cdr p))
(->absolute p))))
(define abs-names
(for/list ([p (in-list abs)])
(match p
[(cons p _) p]
[_ p])))
(define cover-load/use-compiled (make-cover-load/use-compiled abs-names))
(define tests-failed
(parameterize* ([current-load/use-compiled cover-load/use-compiled]
[current-namespace (get-namespace)])
(for ([f (in-list abs-names)])
(vprintf "forcing compilation of ~a" f)
(compile-file f))
(for/fold ([tests-failed #f]) ([f (in-list abs)])
(define failed? (handle-file f submod-name))
(or failed? tests-failed))))
(vprintf "ran ~s\n" files)
(not tests-failed))
(get-receiver))))
;;; ---------------------- Running Aux ---------------------------------
@ -177,8 +180,16 @@ information is converted to a usable form by `get-test-coverage`.
(syntax-source e)
(syntax->datum e)))
(get-topic))
(annotate-top (if (syntax? e) (expand-syntax e) (datum->syntax #f e))
(namespace-base-phase (current-namespace)))]))
(let ([x (annotate-top (if (syntax? e) (expand-syntax e) (datum->syntax #f e))
(namespace-base-phase (current-namespace)))])
(vprintf "current map size is: ~a after compiling ~s\n"
(hash-count (get-raw-coverage-map))
(if (not (syntax? e))
e
(or (syntax-source-file-name e)
(syntax-source e)
(syntax->datum e))))
x)]))
(compile to-compile immediate-eval?)))
cover-compile)
@ -241,17 +252,13 @@ information is converted to a usable form by `get-test-coverage`.
(vprintf "generating test coverage\n")
(define raw-coverage (get-raw-coverage-map))
(define r (get-receiver))
(define receive (cover-receiver raw-coverage))
(let loop ()
(match (sync/timeout (lambda () #f) r)
[(vector info type data _)
(cond [(regexp-match? (regexp-quote logger-init-message) type)
(unless (hash-has-key? raw-coverage data)
(hash-set! raw-coverage data #f))]
[(regexp-match? (regexp-quote logger-covered-message) type)
(hash-set! raw-coverage data #t)])
(loop)]
[#f (void)]))
(define v (sync/timeout (lambda () #f) r))
(when v
(receive v)
(loop)))
;; filtered : (listof (list boolean srcloc))
(define filtered (hash-map raw-coverage
@ -278,6 +285,15 @@ information is converted to a usable form by `get-test-coverage`.
(make-covered? coverage key))))
(f location)))))
(define ((cover-receiver raw-coverage) msg)
(match msg
[(vector info type data _)
(cond [(regexp-match? (regexp-quote logger-init-message) type)
(unless (hash-has-key? raw-coverage data)
(hash-set! raw-coverage data #f))]
[(regexp-match? (regexp-quote logger-covered-message) type)
(hash-set! raw-coverage data #t)])]))
(define current-cover-environment
(make-parameter (make-cover-environment)))

30
cover/private/shared.rkt
View File

@ -3,7 +3,8 @@
logger-init-message
logger-covered-message
with-logging-to-port
with-intercepted-logging)
with-intercepted-logging
with-intercepted-logging/receiver)
(define logger-init-message "init")
(define logger-covered-message "covered")
@ -25,31 +26,32 @@
log-spec))
(define (with-intercepted-logging interceptor proc . log-spec)
(let* ([orig-logger (current-logger)]
;; We use a local logger to avoid getting messages that didn't
;; originate from proc. Since it's a child of the original logger,
;; the rest of the program still sees the log entries.
[logger (make-logger #f orig-logger)]
[receiver (apply make-log-receiver logger log-spec)]
[stop-chan (make-channel)]
[t (receiver-thread receiver stop-chan interceptor)])
(let* ([logger (make-logger #f (current-logger))]
[receiver (apply make-log-receiver logger log-spec)])
(parameterize ([current-logger logger])
(with-intercepted-logging/receiver interceptor proc receiver))))
(define (with-intercepted-logging/receiver interceptor proc receiver)
(let* ([t (receiver-thread receiver interceptor)])
(begin0
(parameterize ([current-logger logger])
(proc))
(channel-put stop-chan 'stop) ; stop the receiver thread
(proc)
(thread-send t 'stop) ; stop the receiver thread
(thread-wait t))))
(define (receiver-thread receiver stop-chan intercept)
(define (receiver-thread receiver intercept)
(thread
(lambda ()
(define thd-receive
(wrap-evt (thread-receive-evt)
(lambda _ (thread-receive))))
(define (clear-events)
(let ([l (sync/timeout 0 receiver)])
(when l ; still something to read
(intercept l) ; interceptor gets the whole vector
(clear-events))))
(let loop ()
(let ([l (sync receiver stop-chan)])
(let ([l (sync receiver thd-receive)])
(cond [(eq? l 'stop)
;; we received all the events we were supposed
;; to get, read them all (w/o waiting), then