suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add a lower-level interface to unstable/logging.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-07-21 11:36:09 -04:00
parent fe58048844
commit b068e4a53b
4 changed files with 117 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/meta/props
View File

@ -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)

18
collects/tests/unstable/logging.rkt Normal file
View File

@ -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)))))))

84
collects/unstable/logging.rkt
View File

@ -2,26 +2,17 @@
(require racket/contract)
(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
;; messages sent to it that didn't originate from proc
[logger (make-logger)]
[receiver (make-log-receiver logger level)]
[stop-chan (make-channel)]
[t (thread (lambda ()
(define (intercept l)
;; we want to send l to the original logger, so that
;; the rest of the system can see it too.
(log-message orig-logger
(vector-ref l 0) ; level
(vector-ref l 1) ; message
(vector-ref l 2)) ; data
(interceptor l))
(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 get the whole vector
(intercept l) ; interceptor gets the whole vector
(clear-events))))
(let loop ()
(let ([l (sync receiver stop-chan)])
@ -32,7 +23,60 @@
(clear-events)]
[else ; keep going
(intercept l)
(loop)])))))])
(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
;; messages sent to it that didn't originate from proc
[logger (make-logger)]
[receiver (make-log-receiver logger level)]
[stop-chan (make-channel)]
[t (receiver-thread
receiver stop-chan
(lambda (l)
;; we want to send l to the original logger, so that
;; the rest of the system can see it too.
(log-message orig-logger
(vector-ref l 0) ; level
(vector-ref l 1) ; message
(vector-ref l 2)) ; data
(interceptor l)))])
(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)]

29
collects/unstable/scribblings/logging.scrbl
View File

@ -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)
]}