75 lines
2.4 KiB
Scheme
75 lines
2.4 KiB
Scheme
|
|
(load-relative "loadtest.ss")
|
|
|
|
(Section 'logger)
|
|
|
|
; --------------------
|
|
|
|
(test #t logger? (current-logger))
|
|
(test #f logger? 17)
|
|
(test #f logger? (make-log-receiver (current-logger) 'error))
|
|
(test #t log-receiver? (make-log-receiver (current-logger) 'error))
|
|
(test #f log-receiver? (current-logger))
|
|
|
|
(test #f logger-name (make-logger))
|
|
|
|
(arity-test make-logger 0 2)
|
|
|
|
; --------------------
|
|
|
|
(let ([l (make-logger 'test)]
|
|
[test-level (lambda (on? l level . lrs)
|
|
(test on? log-level? l level)
|
|
(for-each (lambda (lr)
|
|
(test #f sync/timeout 0 lr))
|
|
lrs)
|
|
(log-message l level "message" 'data)
|
|
(for-each (lambda (lr)
|
|
(test (and on?
|
|
(vector level (format "~a: message" (logger-name l)) 'data))
|
|
sync/timeout 0 lr))
|
|
lrs))])
|
|
(test #t logger? l)
|
|
(test 'test logger-name l)
|
|
(test-level #f l 'fatal)
|
|
(test-level #f l 'error)
|
|
(test-level #f l 'warning)
|
|
(test-level #f l 'info)
|
|
(test-level #f l 'debug)
|
|
(let ([lr (make-log-receiver l 'warning)])
|
|
(test-level #t l 'fatal lr)
|
|
(test-level #t l 'error lr)
|
|
(test-level #t l 'warning lr)
|
|
(test-level #f l 'info lr)
|
|
(test-level #f l 'debug lr)
|
|
(let ([sub-l (make-logger 'test.sub l)])
|
|
(test 'test logger-name l)
|
|
(test 'test.sub logger-name sub-l)
|
|
(test-level #t l 'fatal lr)
|
|
(test-level #t l 'error lr)
|
|
(test-level #t l 'warning lr)
|
|
(test-level #f l 'info lr)
|
|
(test-level #f l 'debug lr)
|
|
(test-level #t sub-l 'fatal lr)
|
|
(test-level #t sub-l 'error lr)
|
|
(test-level #t sub-l 'warning lr)
|
|
(test-level #f sub-l 'info lr)
|
|
(test-level #f sub-l 'debug lr)
|
|
(let ([lr2 (make-log-receiver sub-l 'info)])
|
|
(test-level #t l 'fatal lr)
|
|
(test-level #t l 'error lr)
|
|
(test-level #t l 'warning lr)
|
|
(test-level #f l 'info lr)
|
|
(test-level #f l 'debug lr)
|
|
(test-level #t sub-l 'fatal lr lr2)
|
|
(test-level #t sub-l 'error lr lr2)
|
|
(test-level #t sub-l 'warning lr lr2)
|
|
(test-level #t sub-l 'info lr2)
|
|
(test-level #f sub-l 'debug lr lr2)
|
|
;; Make sure they're not GCed before here:
|
|
(list lr lr2)))))
|
|
|
|
; --------------------
|
|
|
|
(report-errs)
|