59 lines
2.5 KiB
Racket
59 lines
2.5 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/contract)
|
|
|
|
(define (with-intercepted-logging interceptor proc #:level [level 'debug])
|
|
(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
|
|
(intercept l) ; interceptor get the whole vector
|
|
(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
|
|
(intercept l)
|
|
(loop)])))))])
|
|
(begin0
|
|
(parameterize ([current-logger logger])
|
|
(proc))
|
|
(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))
|
|
|
|
(define level/c (or/c 'fatal 'error 'warning 'info 'debug))
|
|
|
|
(provide/contract [with-intercepted-logging
|
|
(->* ((-> (vector/c level/c string? any/c) any)
|
|
(-> any))
|
|
(#:level level/c)
|
|
any)]
|
|
[with-logging-to-port
|
|
(->* (output-port? (-> any))
|
|
(#:level level/c)
|
|
any)])
|