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

Fix limitations of with-intercepted-logging.

Browse Source 
original commit: b71d3cf40c1dee167ff1c737ede7496cd159f281
This commit is contained in:
Vincent St-Amour 2011-06-01 15:57:34 -04:00
parent addca29b35
commit a84dc148cd
1 changed files with 16 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/unstable/logging.rkt
View File

@ -2,24 +2,26 @@
(require racket/contract)
;; Known limitations:
;; - If another thread is logging while t is running, these messages will be
;; intercepted as well, even if they don't come from proc.
;; - In the following example:
;; (with-logging-to-port port level
;; (lambda () (log-warning "ok") 3))
;; (log-warning "not ok")
;; If the logging on the last line is executed before the thread listening
;; to the logs sees the stop message, "not ok" will also be sent to port.
(define (with-intercepted-logging interceptor proc #:level [level 'debug])
(let* ([logger (make-logger #f (current-logger))]
[receiver (make-log-receiver logger level)]
[stop-chan (make-channel)]
(let* ([orig-logger (current-logger)]
;; the new logger is unrelated to the original, to avoid getting
;; messages sent to it that didn't originate from proc
[logger (make-logger)]
[receiver (make-log-receiver logger level)]
[stop-chan (make-channel)]
[t (thread (lambda ()
(define (intercept l)
;; we want to send l to the original logger, so that
;; the rest of the system can see it too.
(log-message orig-logger
(vector-ref l 0) ; level
(vector-ref l 1) ; message
(vector-ref l 2)) ; data
(interceptor l))
(define (clear-events)
(let ([l (sync/timeout 0 receiver)])
(when l ; still something to read
(interceptor l) ; interceptor get the whole vector
(intercept l) ; interceptor get the whole vector
(clear-events))))
(let loop ()
(let ([l (sync receiver stop-chan)])
@ -29,7 +31,7 @@
;; stop
(clear-events)]
[else ; keep going
(interceptor l)
(intercept l)
(loop)])))))])
(begin0
(parameterize ([current-logger logger])