1#lang racket/base 2(require "../common/check.rkt" 3 "../host/thread.rkt" 4 "../host/place-local.rkt" 5 "logger.rkt" 6 "level.rkt" 7 "wanted.rkt" 8 "receiver.rkt") 9 10(provide logger? 11 logger-name 12 current-logger 13 unsafe-root-logger 14 make-logger 15 log-level? 16 log-level?* ; ok to call in host-Scheme interrupt handler 17 log-max-level 18 log-all-levels 19 log-level-evt 20 log-message 21 log-message* ; ok to call in host-Scheme interrupt handler 22 log-receiver? 23 make-log-receiver 24 add-stderr-log-receiver! 25 add-stdout-log-receiver! 26 add-syslog-log-receiver! 27 logger-init! 28 logging-future-events? 29 log-future-event 30 logging-place-events? 31 log-place-event) 32 33(define (make-root-logger) 34 (create-logger #:topic #f #:parent #f #:propagate-filters 'none)) 35 36(define-place-local root-logger (make-root-logger)) 37 38(define (unsafe-root-logger) root-logger) 39 40(define current-logger 41 (make-parameter root-logger 42 (lambda (l) 43 (unless (logger? l) 44 (raise-argument-error 'current-logger "logger?" l)) 45 l) 46 'current-logger)) 47 48(define (logger-init!) 49 (set! root-logger (make-root-logger)) 50 (current-logger root-logger)) 51 52(define (make-logger [topic #f] [parent #f] . filters) 53 (unless (or (not topic) (symbol? topic)) 54 (raise-argument-error 'make-logger "(or/c symbol? #f)" topic)) 55 (unless (or (not parent) (logger? parent)) 56 (raise-argument-error 'make-logger "(or/c logger? #f)" parent)) 57 (create-logger #:topic topic 58 #:parent parent 59 #:propagate-filters (parse-filters 'make-logger filters #:default-level 'debug))) 60 61;; Can be called in any host Scheme thread, including in an interrupt 62;; handler (where "interrupt" is a host-Scheme concept, such as a GC 63;; handler). If it's not the thread that runs Racket, then it's in 64;; atomic, non-interrupt mode and we assume that the argument checks 65;; will pass. 66(define/who (log-level? logger level [topic #f]) 67 (check who logger? logger) 68 (check-level who level) 69 (check who #:or-false symbol? topic) 70 (atomically/no-interrupts/no-wind 71 (log-level?* logger level topic))) 72 73(define (logging-future-events?) 74 (atomically/no-interrupts/no-wind 75 (log-level?* root-logger 'debug 'future))) 76 77(define (logging-place-events?) 78 (atomically/no-interrupts/no-wind 79 (log-level?* root-logger 'debug 'place))) 80 81;; In atomic mode with interrupts disabled 82(define/who (log-level?* logger level topic) 83 (level>=? (logger-wanted-level logger topic) level)) 84 85(define/who (log-max-level logger [topic #f]) 86 (check who logger? logger) 87 (check who #:or-false symbol? topic) 88 (level->user-representation 89 (atomically/no-interrupts/no-wind 90 (logger-wanted-level logger topic)))) 91 92(define/who (log-all-levels logger) 93 (check who logger? logger) 94 (logger-all-levels logger)) 95 96(define/who (log-level-evt logger) 97 (check who logger? logger) 98 (define s 99 (atomically 100 (cond 101 [(unbox (logger-level-sema-box logger)) 102 => (lambda (s) s)] 103 [else 104 (define s (make-semaphore)) 105 (set-box! (logger-level-sema-box logger) s) 106 s]))) 107 (semaphore-peek-evt s)) 108 109(define/who log-message 110 ;; Complex dispatch based on number and whether third is a string: 111 (case-lambda 112 [(logger level message) 113 (define topic (and (logger? logger) (logger-name logger))) 114 (do-log-message who logger level topic message #f #t)] 115 [(logger level topic/message message/data) 116 (cond 117 [(string? topic/message) 118 (define topic (and (logger? logger) (logger-name logger))) 119 (do-log-message who logger level topic topic/message message/data #t)] 120 [(or (not topic/message) (symbol? topic/message)) 121 (do-log-message who logger level topic/message message/data #f #t)] 122 [else 123 (check who logger? logger) 124 (check-level who level) 125 (raise-argument-error who "(or/c string? symbol?)" topic/message)])] 126 [(logger level topic/message message/data data/prefix?) 127 (cond 128 [(string? topic/message) 129 (define topic (and (logger? logger) (logger-name logger))) 130 (do-log-message who logger level topic topic/message message/data data/prefix?)] 131 [(or (not topic/message) (symbol? topic/message)) 132 (do-log-message who logger level topic/message message/data data/prefix? #t)] 133 [else 134 (check who logger? logger) 135 (check-level who level) 136 (raise-argument-error who "(or/c string? symbol?)" topic/message)])] 137 [(logger level topic message data prefix?) 138 (do-log-message who logger level topic message data prefix?)])) 139 140(define (do-log-message who logger level topic message data prefix?) 141 (check who logger? logger) 142 (check-level who level) 143 (check who #:or-false symbol? topic) 144 (check who string? message) 145 (atomically/no-interrupts/no-wind 146 (log-message* logger level topic message data prefix? #f))) 147 148(define (log-future-event message data) 149 (atomically/no-interrupts/no-wind 150 (log-message* root-logger 'debug 'future message data #t #f))) 151 152(define (log-place-event message data) 153 (atomically/no-interrupts/no-wind 154 (log-message* root-logger 'debug 'place message data #t #f))) 155 156;; In atomic mode with interrupts disabled 157;; Can be called in any host Scheme thread and in interrupt handler, 158;; like `log-level?*` 159(define (log-message* logger level topic message data prefix? in-interrupt?) 160 (define msg #f) 161 (when ((logger-max-wanted-level* logger) . level>=? . level) 162 (let loop ([logger logger]) 163 (for ([r (in-list (logger-receivers logger))]) 164 (when ((filters-level-for-topic (log-receiver-filters r) topic) . level>=? . level) 165 (unless msg 166 (set! msg (vector-immutable 167 level 168 (string->immutable-string 169 (if (and prefix? topic) 170 (string-append (symbol->string topic) 171 ": " 172 message) 173 message)) 174 data 175 topic))) 176 (log-receiver-send! r msg in-interrupt?))) 177 (let ([parent (logger-parent logger)]) 178 (when (and parent 179 ((filters-level-for-topic (logger-propagate-filters logger) topic) . level>=? . level)) 180 (loop parent)))))) 181