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

Implement with-logging-to-port in terms of something more general.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-06-01 15:34:01 -04:00
parent 0538f21274
commit fc705c6e29
1 changed files with 10 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/unstable/logging.rkt
View File

@ -4,25 +4,22 @@
;; Known limitations:
;; - If another thread is logging while t is running, these messages will be
;; sent to the port as well, even if they don't come from proc.
;; 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-logging-to-port port proc #:level [level 'debug])
(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)]
[t (thread (lambda ()
(define (output-event l)
(displayln (vector-ref l 1) ; actual message
port))
(define (clear-events)
(let ([l (sync/timeout 0 receiver)])
(when l ; still something to read
(output-event l)
(interceptor l) ; interceptor get the whole vector
(clear-events))))
(let loop ()
(let ([l (sync receiver stop-chan)])
@ -32,7 +29,7 @@
;; stop
(clear-events)]
[else ; keep going
(output-event l)
(interceptor l)
(loop)])))))])
(begin0
(parameterize ([current-logger logger])
@ -40,6 +37,12 @@
(channel-put stop-chan 'stop) ; stop the receiver thread
(thread-wait t))))
(define (with-logging-to-port port proc #:level [level 'debug])
(with-intercepted-logging
(lambda (l) (displayln (vector-ref l 1) ; actual message
port))
proc #:level level))
(provide/contract [with-logging-to-port
(->* (output-port? (-> any))
(#:level (or/c 'fatal 'error 'warning 'info 'debug))