From fc705c6e29b585ee8f774175d55cabf52035e061 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 1 Jun 2011 15:34:01 -0400
Subject: [PATCH] Implement with-logging-to-port in terms of something more
 general.

---
 collects/unstable/logging.rkt | 17 ++++++++++-------
 1 file changed, 10 insertions(+), 7 deletions(-)

diff --git a/collects/unstable/logging.rkt b/collects/unstable/logging.rkt
index 9d2a7018ce..606a874876 100644
--- a/collects/unstable/logging.rkt
+++ b/collects/unstable/logging.rkt
@@ -4,25 +4,22 @@
 
 ;; 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.
+;;   intercepted 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])
+(define (with-intercepted-logging interceptor 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)
+                            (interceptor l) ; interceptor get the whole vector
                             (clear-events))))
                       (let loop ()
                         (let ([l (sync receiver stop-chan)])
@@ -32,7 +29,7 @@
                                  ;; stop
                                  (clear-events)]
                                 [else ; keep going
-                                 (output-event l)
+                                 (interceptor l)
                                  (loop)])))))])
     (begin0
         (parameterize ([current-logger logger])
@@ -40,6 +37,12 @@
       (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))
+
 (provide/contract [with-logging-to-port
                    (->* (output-port? (-> any))
                         (#:level (or/c 'fatal 'error 'warning 'info 'debug))