47 lines
2.0 KiB
Racket
47 lines
2.0 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/contract)
|
|
|
|
;; 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.
|
|
;; - 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])
|
|
(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)
|
|
(clear-events))))
|
|
(let loop ()
|
|
(let ([l (sync receiver stop-chan)])
|
|
(cond [(eq? l 'stop)
|
|
;; we received all the events we were supposed
|
|
;; to get, read them all (w/o waiting), then
|
|
;; stop
|
|
(clear-events)]
|
|
[else ; keep going
|
|
(output-event l)
|
|
(loop)])))))])
|
|
(begin0
|
|
(parameterize ([current-logger logger])
|
|
(proc))
|
|
(channel-put stop-chan 'stop) ; stop the receiver thread
|
|
(thread-wait t))))
|
|
|
|
(provide/contract [with-logging-to-port
|
|
(->* (output-port? (-> any))
|
|
(#:level (or/c 'fatal 'error 'warning 'info 'debug))
|
|
any)])
|