diff --git a/pkgs/racket-doc/scribblings/reference/logging.scrbl b/pkgs/racket-doc/scribblings/reference/logging.scrbl index 96155a692c..6136135c1c 100644 --- a/pkgs/racket-doc/scribblings/reference/logging.scrbl +++ b/pkgs/racket-doc/scribblings/reference/logging.scrbl @@ -132,7 +132,9 @@ Reports @racket[logger]'s default topic, if any.} A @tech{parameter} that determines the @tech{current logger}.} -@defform[(define-logger id)]{ +@defform[(define-logger id maybe-parent) + #:grammar ([maybe-parent (code:line) (code:line #:parent parent-expr)]) + #:contracts ([parent-expr (or/c logger? #f)])]{ Defines @racketkeywordfont{log-}@racket[id]@racketkeywordfont{-fatal}, @racketkeywordfont{log-}@racket[id]@racketkeywordfont{-error}, @@ -142,10 +144,14 @@ Defines @racketkeywordfont{log-}@racket[id]@racketkeywordfont{-fatal}, like @racket[log-fatal], @racket[log-error],@racket[log-warning], @racket[log-info], and @racket[log-debug]. The @racket[define-logger] form also defines @racket[id]@racketidfont{-logger}, which is a logger with -default topic @racket['@#,racket[id]] that is a child of @racket[(current-logger)]; -the @racketkeywordfont{log-}@racket[id]@racketkeywordfont{-fatal}, -@|etc| forms use this new logger. The new logger is -created when @racket[define-logger] is evaluated.} +default topic @racket['@#,racket[id]] that is a child of the result of +@racket[parent-expr] (if @racket[parent-expr] does not produce @racket[#f]), +or of @racket[(current-logger)] if @racket[parent-expr] not provided; the +@racketkeywordfont{log-}@racket[id]@racketkeywordfont{-fatal}, @|etc| forms +use this new logger. The new logger is created when @racket[define-logger] +is evaluated. + +@history[#:changed "7.1.0.9" @elem{Added the @racket[#:parent] option.}]} @; ---------------------------------------- @section{Logging Events} diff --git a/pkgs/racket-test-core/tests/racket/logger.rktl b/pkgs/racket-test-core/tests/racket/logger.rktl index d320f79947..69a1a85d2d 100644 --- a/pkgs/racket-test-core/tests/racket/logger.rktl +++ b/pkgs/racket-test-core/tests/racket/logger.rktl @@ -290,6 +290,35 @@ ;; If receiver is GCed, then this will block (sync s)) +; -------------------- +; `define-logger` with explicit parent + +(let () + (define-logger parent) + (define-logger child #:parent parent-logger) + (define r (make-log-receiver parent-logger 'warning 'child)) + (log-child-debug "debug") + (test #f sync/timeout 0 r) + (log-child-warning "warning") + (test "child: warning" (lambda (v) (vector-ref v 1)) (sync r))) + +(let () + (define-logger parent) + (define parent-receiver (make-log-receiver parent-logger 'warning 'no-parent)) + (parameterize ([current-logger parent-logger]) + (define-logger no-parent #:parent #f) + (define no-parent-receiver (make-log-receiver no-parent-logger 'warning 'no-parent)) + (log-no-parent-warning "warning") + (test #f sync/timeout 0 parent-receiver) + (test "no-parent: warning" (lambda (v) (vector-ref v 1)) (sync no-parent-receiver)))) + +(err/rt-test + (let () + (define-logger test #:parent 'not-a-logger) + (void)) + exn:fail:contract? + #rx"define-logger: contract violation.+expected: \\(or/c logger\\? #f\\).+given: 'not-a-logger") + ; -------------------- (report-errs) diff --git a/racket/collects/racket/private/logger.rkt b/racket/collects/racket/private/logger.rkt index a96451d942..2ec75d297f 100644 --- a/racket/collects/racket/private/logger.rkt +++ b/racket/collects/racket/private/logger.rkt @@ -27,15 +27,17 @@ (define-syntax log-info (make-define-log 'info #'(current-logger) #'(logger-name l))) (define-syntax log-debug (make-define-log 'debug #'(current-logger) #'(logger-name l))) - (define (check-logger who) - (lambda (v) - (unless (logger? v) - (raise-argument-error who "logger?" v)) - v)) + (define (check-logger-or-false who v) + (unless (or (not v) (logger? v)) + (raise-argument-error who "(or/c logger? #f)" v)) + v) (define-syntax (define-logger stx) (syntax-case stx () - [(_ X) + [(d-l X) + (syntax/loc stx + (d-l X #:parent (current-logger)))] + [(d-l X #:parent parent) (let* ([X #'X] [mk (lambda (mode) (datum->syntax X (string->symbol (format "log-~a-~a" (syntax-e X) mode)) X))]) @@ -50,7 +52,7 @@ (datum->syntax X (string->symbol (format "~a-logger" (syntax-e X))) X)] [X X]) #'(begin - (define X-logger (make-logger 'X (current-logger))) + (define X-logger (make-logger 'X (check-logger-or-false 'd-l parent))) (define-syntax log-X-fatal (make-define-log 'fatal #'X-logger #''X)) (define-syntax log-X-error (make-define-log 'error #'X-logger #''X)) (define-syntax log-X-warning (make-define-log 'warning #'X-logger #''X))