From 2acacf128484cb254a92e0decd1daeada1954a1d Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 31 May 2011 19:12:08 -0400 Subject: [PATCH] Add with-logging-to-port to unstable. original commit: 8d96133681a1302c9395485b969049c9a072d552 --- collects/unstable/logging.rkt | 38 +++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) create mode 100644 collects/unstable/logging.rkt diff --git a/collects/unstable/logging.rkt b/collects/unstable/logging.rkt new file mode 100644 index 00000000..afe353e3 --- /dev/null +++ b/collects/unstable/logging.rkt @@ -0,0 +1,38 @@ +#lang racket/base + +(require racket/contract) + +(define (with-logging-to-port port level proc) + (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? + (or/c 'fatal 'error 'warning 'info 'debug) + (-> any) + any)])