diff --git a/pollen/private/external/logging.rkt b/pollen/private/external/logging.rkt new file mode 100644 index 0000000..70c001b --- /dev/null +++ b/pollen/private/external/logging.rkt @@ -0,0 +1,69 @@ +#lang racket/base + +;; 181030: Needed for compatibility with Racket 6.0. +;; This module introduced until 6.3. + +(require racket/contract/base) + +(provide log-level/c) + +(define log-level/c (or/c 'none 'fatal 'error 'warning 'info 'debug)) +(define log-spec? (listof (or/c symbol? #f))) +(define log-event? (vector-immutable/c log-level/c string? any/c (or/c symbol? #f))) + +(provide/contract [with-intercepted-logging + (->* ((-> log-event? any) + (-> any) + log-level/c) + (#:logger logger?) + #:rest log-spec? + any)] + [with-logging-to-port + (->* (output-port? (-> any) log-level/c) + (#:logger logger?) + #:rest log-spec? + any)]) + +(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)])))))) + +(define (with-intercepted-logging interceptor proc #:logger [logger #f] + . log-spec) + (let* ([orig-logger (current-logger)] + ;; Unless we're provided with an explicit logger to monitor 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 (or 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 #:logger [logger #f] . log-spec) + (apply with-intercepted-logging + #:logger logger + (lambda (l) (displayln (vector-ref l 1) ; actual message + port)) + proc + log-spec)) diff --git a/pollen/private/log.rkt b/pollen/private/log.rkt index 7f3f2a3..d8ae533 100644 --- a/pollen/private/log.rkt +++ b/pollen/private/log.rkt @@ -1,9 +1,9 @@ #lang racket/base (require racket/format racket/string - racket/logging) + "external/logging.rkt") -(provide (all-defined-out) (all-from-out racket/logging)) +(provide (all-defined-out) (all-from-out "external/logging.rkt")) ;; creates `pollen-logger` and associated functions: ;; log-pollen-fatal, log-pollen-error, log-pollen-warning,