Add a lower-level interface to unstable/logging.

collects/meta/props

@@ -1965,6 +1965,7 @@ path/s is either such a string or a list of them.
 "collects/tests/unstable/byte-counting-port.rkt" responsible (jay)
 "collects/tests/unstable/generics.rkt" responsible (jay)
 "collects/tests/unstable/list.rkt" responsible (jay)
+"collects/tests/unstable/logging.rkt" responsible (stamourv)
 "collects/tests/unstable/srcloc.rktl" responsible (cce) drdr:command-line (racket "-f" *)
 "collects/tests/unstable/temp-c" responsible (jay)
 "collects/tests/utils/gui.rkt" drdr:command-line (gracket-text "-t" *)
@@ -2017,12 +2018,14 @@ path/s is either such a string or a list of them.
 "collects/unstable/gui/slideshow.rkt" drdr:command-line (gracket-text "-t" *)
 "collects/unstable/gui/window.rkt" drdr:command-line (gracket-text "-t" *)
 "collects/unstable/hash.rkt" responsible (samth)
+"collects/unstable/logging.rkt" responsible (stamourv)
 "collects/unstable/match.rkt" responsible (samth)
 "collects/unstable/mutated-vars.rkt" responsible (samth)
 "collects/unstable/poly-c.rkt" responsible (samth)
 "collects/unstable/scribblings/byte-counting-port.scrbl" responsible (jay)
 "collects/unstable/scribblings/debug.scrbl" responsible (samth)
 "collects/unstable/scribblings/hash.scrbl" responsible (samth)
+"collects/unstable/scribblings/logging.scrbl" responsible (stamourv)
 "collects/unstable/scribblings/match.scrbl" responsible (samth)
 "collects/unstable/scribblings/mutated-vars.scrbl" responsible (samth)
 "collects/unstable/scribblings/poly-c.scrbl" responsible (samth)

collects/tests/unstable/logging.rkt

@@ -0,0 +1,18 @@
+#lang racket/base
+
+(require rackunit rackunit/text-ui unstable/logging)
+
+(run-tests
+ (test-suite "logging.rkt"
+   (test-case "start/stop-recording"
+     (let ([l (start-recording #:level 'warning)])
+       (log-warning "1")
+       (log-warning "2")
+       (log-warning "3")
+       (log-info "4")
+       (stop-recording l) ; stopping should be idempotent
+       (let ([out (stop-recording l)])
+         (check-equal? (map (lambda (l) (vector-ref l 1)) out)
+                       '("1" "2" "3"))
+         (check-true (andmap (lambda (l) (eq? (vector-ref l 0) 'warning))
+                             out)))))))

collects/unstable/logging.rkt

@@ -2,6 +2,64 @@
 
 (require racket/contract)
 
+(define level/c (or/c 'fatal 'error 'warning 'info 'debug))
+(define log-message/c (vector/c level/c string? any/c))
+
+;; 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 #:level [level 'debug])
+  (let* ([receiver     (make-log-receiver (current-logger) level)]
+         [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 (->* () (#:level level/c) listener?)]
+ [stop-recording  (-> listener? (listof log-message/c))])
+
+
 (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
@@ -9,30 +67,16 @@
          [logger      (make-logger)]
          [receiver    (make-log-receiver logger level)]
          [stop-chan   (make-channel)]
-         [t (thread (lambda ()
+         [t (receiver-thread
-                      (define (intercept l)
+             receiver stop-chan
-                        ;; we want to send l to the original logger, so that
+             (lambda (l)
-                        ;; the rest of the system can see it too.
+               ;; we want to send l to the original logger, so that
-                        (log-message orig-logger
+               ;; the rest of the system can see it too.
-                                     (vector-ref l 0)  ; level
+               (log-message orig-logger
-                                     (vector-ref l 1)  ; message
+                            (vector-ref l 0)  ; level
-                                     (vector-ref l 2)) ; data
+                            (vector-ref l 1)  ; message
-                        (interceptor l))
+                            (vector-ref l 2)) ; data
-                      (define (clear-events)
+               (interceptor l)))])
-                        (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))
@@ -45,10 +89,8 @@
                           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)
+                   (->* ((-> log-message/c any)
                          (-> any))
                         (#:level level/c)
                         any)]

collects/unstable/scribblings/logging.scrbl

@@ -14,7 +14,7 @@ This module provides tools for logging.
 
 @defproc[(with-logging-to-port
            [port output-port?] [proc (-> any)]
-           [#:level level (or/c 'fatal 'error 'warning 'info 'debug) 'info])
+           [#:level level (or/c 'fatal 'error 'warning 'info 'debug) 'debug])
          any]{
 
 Runs @racket[proc], outputting any logging of level @racket[level] or higher to
@@ -38,7 +38,7 @@ Runs @racket[proc], outputting any logging of level @racket[level] or higher to
 			      any/c)
 			     any)]
            [proc (-> any)]
-           [#:level level (or/c 'fatal 'error 'warning 'info 'debug) 'info])
+           [#:level level (or/c 'fatal 'error 'warning 'info 'debug) 'debug])
          any]{
 
 Runs @racket[proc], calling @racket[interceptor] on any log message of level
@@ -60,3 +60,28 @@ as arguments. Returns whatever @racket[proc] returns.
       (+ 2 2))
     #:level 'warning)
   warning-counter)]}
+
+
+A lower-level interface to logging is also available.
+
+@deftogether[[
+  @defproc[(start-recording
+            [#:level level (or/c 'fatal 'error 'warning 'info 'debug) 'debug])
+           listener?]
+  @defproc[(stop-recording [listener listener?])
+           (listof (vector/c (or/c 'fatal 'error 'warning 'info 'debug)
+                             string?
+                             any/c))]]]{
+
+@racket[start-recording] starts recording log messages of the desired level or
+higher. Messages will be recorded until stopped by passing the returned
+listener object to @racket[stop-recording]. @racket[stop-recording] will then
+return a list of the log messages that have been reported.
+
+@defexamples[
+#:eval the-eval
+(define l (start-recording #:level 'warning))
+(log-warning "1")
+(log-warning "2")
+(stop-recording l)
+]}