You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
70 lines
2.6 KiB
Racket
70 lines
2.6 KiB
Racket
#lang racket/base
|
|
|
|
;; 190303: Needed for compatibility with Rackets < 6.7.
|
|
;; #:logger argument not introduced until 6.7
|
|
|
|
(require racket/contract/base)
|
|
|
|
(provide log-level/c)
|
|
|
|
(define log-level/c (or/c 'none 'fatal 'error 'warning 'info 'debug))
|
|
(define log-spec? (listof (or/c symbol? #f)))
|
|
(define log-event? (vector-immutable/c log-level/c string? any/c (or/c symbol? #f)))
|
|
|
|
(provide/contract [with-intercepted-logging
|
|
(->* ((-> log-event? any)
|
|
(-> any)
|
|
log-level/c)
|
|
(#:logger logger?)
|
|
#:rest log-spec?
|
|
any)]
|
|
[with-logging-to-port
|
|
(->* (output-port? (-> any) log-level/c)
|
|
(#:logger logger?)
|
|
#:rest log-spec?
|
|
any)])
|
|
|
|
(define (receiver-thread receiver stop-chan intercept)
|
|
(thread
|
|
(lambda ()
|
|
(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)])
|
|
(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)]))))))
|
|
|
|
(define (with-intercepted-logging interceptor proc #:logger [logger #f]
|
|
. log-spec)
|
|
(let* ([orig-logger (current-logger)]
|
|
;; Unless we're provided with an explicit logger to monitor 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 (or 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)])
|
|
(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 #:logger [logger #f] . log-spec)
|
|
(apply with-intercepted-logging
|
|
#:logger logger
|
|
(lambda (l) (displayln (vector-ref l 1) ; actual message
|
|
port))
|
|
proc
|
|
log-spec))
|