ffd81f136f
The synchronization result of a log receiver is now a vector of four values, instead of three, where the last one reports the name. Also, an optional argument to `make-logger' provides a notification callback for each event sent to the logger. These changes enable more control over loggers and events. Suppose that you have processes A and B, and you want all log events of A to be visible to B, but not vice-versa. Furthermore, you want the log events to appear at B in the right order: if A logs an event before B, then A's event should arrive at a log receiver's before B's. Now that a log receiver gets the name associated with the original event, and now that the name can be re-sent in a `log-receiver', it's possible to give A and B separate loggers and send all of the events from A's logger to B's logger. Furthermore, you can use the notification callback so that when an event is logged in B, you can make sure that all available events from from A's logger have been transferred to B's logger. original commit: f2d870859aad7cf21d96f81f1f9dfc0eae8adaa7
95 lines
3.4 KiB
Racket
95 lines
3.4 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/contract/base)
|
|
|
|
(define level/c (or/c 'fatal 'error 'warning 'info 'debug))
|
|
(define log-spec/c (listof (or/c symbol? #f)))
|
|
(define log-message/c (vector/c level/c string? any/c (or/c symbol? #f)))
|
|
|
|
;; helper used below
|
|
(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)]))))))
|
|
|
|
(struct listener (stop-chan
|
|
;; ugly, but the thread and the listener need to know each
|
|
;; other
|
|
[thread #:mutable]
|
|
[rev-messages #:mutable]
|
|
[done? #:mutable]))
|
|
|
|
;; [level] -> listener
|
|
(define (start-recording . log-spec)
|
|
(let* ([receiver (apply make-log-receiver (current-logger) log-spec)]
|
|
[stop-chan (make-channel)]
|
|
[cur-listener (listener stop-chan #f '() #f)]
|
|
[t (receiver-thread
|
|
receiver stop-chan
|
|
(lambda (l)
|
|
(set-listener-rev-messages!
|
|
cur-listener
|
|
(cons l (listener-rev-messages cur-listener)))))])
|
|
(set-listener-thread! cur-listener t)
|
|
cur-listener))
|
|
|
|
;; listener -> listof messages
|
|
(define (stop-recording cur-listener)
|
|
(unless (listener-done? cur-listener)
|
|
(channel-put (listener-stop-chan cur-listener)
|
|
'stop) ; stop the receiver thread
|
|
(thread-wait (listener-thread cur-listener))
|
|
(set-listener-done?! cur-listener #t))
|
|
(reverse (listener-rev-messages cur-listener)))
|
|
|
|
(provide/contract
|
|
[start-recording (->* () #:rest log-spec/c listener?)]
|
|
[stop-recording (-> listener? (listof log-message/c))])
|
|
|
|
|
|
(define (with-intercepted-logging interceptor proc . log-spec)
|
|
(let* ([orig-logger (current-logger)]
|
|
;; 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 (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 . log-spec)
|
|
(apply with-intercepted-logging
|
|
(lambda (l) (displayln (vector-ref l 1) ; actual message
|
|
port))
|
|
proc
|
|
log-spec))
|
|
|
|
(provide/contract [with-intercepted-logging
|
|
(->* ((-> log-message/c any)
|
|
(-> any))
|
|
#:rest log-spec/c
|
|
any)]
|
|
[with-logging-to-port
|
|
(->* (output-port? (-> any))
|
|
#:rest log-spec/c
|
|
any)])
|