Added a store to simple-log.
This commit is contained in:
@@ -0,0 +1,188 @@
|
||||
#lang racket
|
||||
|
||||
(require data/queue
|
||||
racket/contract
|
||||
"loghash.rkt"
|
||||
)
|
||||
|
||||
(provide make-sl-store
|
||||
sl-store-grep-message
|
||||
sl-store-grep-topic
|
||||
sl-store-grep-level
|
||||
sl-store-grep
|
||||
sl-store-tail
|
||||
sl-store-enqueue!
|
||||
sl-store->list
|
||||
sl-store->display
|
||||
sl-store-length
|
||||
sl-store-max-length
|
||||
)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Data structures
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-struct sl-store
|
||||
(max-length [length #:mutable] queue)
|
||||
)
|
||||
|
||||
(define-struct sl-store-item
|
||||
(topic level date-time message))
|
||||
|
||||
(define make-sl-store* make-sl-store)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Internal functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(set! make-sl-store (λ ([max-length 1000])
|
||||
(make-sl-store* max-length 0 (make-queue))))
|
||||
|
||||
(define levels '(debug info warning warn err error dbg fatal))
|
||||
|
||||
(define (level? l)
|
||||
(memq l levels))
|
||||
|
||||
(define (copy-queue q pred)
|
||||
(let ((nq (make-queue)))
|
||||
(sequence-for-each
|
||||
(λ (item)
|
||||
(when (pred item)
|
||||
(enqueue! nq item)))
|
||||
(in-queue q))
|
||||
nq))
|
||||
|
||||
(define (level-regexp->level l-re [raise-error #t])
|
||||
(let ((str-levels (map symbol->string levels)))
|
||||
(letrec ((f (λ (l)
|
||||
(if (null? l)
|
||||
(if raise-error
|
||||
(error (format "Regular expression '~a' does not match a level"))
|
||||
'debug)
|
||||
(if (regexp-match? l-re (car l))
|
||||
(string->symbol (car l))
|
||||
(f (cdr l)))
|
||||
)
|
||||
)
|
||||
))
|
||||
(f str-levels))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; API
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define/contract (sl-store-enqueue! store topic level date-time msg)
|
||||
(-> sl-store? symbol? level? string? string? void?)
|
||||
(void
|
||||
(let ((queue (sl-store-queue store))
|
||||
(ml (sl-store-max-length store)))
|
||||
(enqueue! queue (make-sl-store-item topic level date-time msg))
|
||||
(set-sl-store-length! store (+ (sl-store-length store) 1))
|
||||
(let loop ()
|
||||
(if (> (queue-length queue) ml)
|
||||
(begin
|
||||
(dequeue! queue)
|
||||
(set-sl-store-length! store (- sl-store-length store) 1)
|
||||
(loop))
|
||||
#t))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define/contract (sl-store->list store)
|
||||
(-> sl-store? list?)
|
||||
(map (λ (item)
|
||||
(list (sl-store-item-topic item)
|
||||
(sl-store-item-level item)
|
||||
(sl-store-item-date-time item)
|
||||
(sl-store-item-message item)))
|
||||
(queue->list (sl-store-queue store))))
|
||||
|
||||
(define/contract (sl-store->display store)
|
||||
(-> sl-store? void?)
|
||||
(void
|
||||
(for-each (λ (e)
|
||||
(displayln
|
||||
(format "~a:~a:~a:~a" (car e) (cadr e) (caddr e) (cadddr e))))
|
||||
(sl-store->list store))))
|
||||
|
||||
(define/contract (sl-store-grep-level store level)
|
||||
(-> sl-store? (or/c regexp? level?) sl-store?)
|
||||
(let* ((lvl (if (level? level) level (level-regexp->level level)))
|
||||
(num-level (hash-ref log-hash lvl 0)))
|
||||
(let ((nq (copy-queue (sl-store-queue store)
|
||||
(λ (item)
|
||||
(let ((num-level-item (hash-ref log-hash
|
||||
(sl-store-item-level item)
|
||||
0)))
|
||||
(>= num-level-item num-level))))))
|
||||
(make-sl-store* (sl-store-max-length store)
|
||||
(queue-length nq)
|
||||
nq))))
|
||||
|
||||
|
||||
(define/contract (sl-store-grep-topic store regexp)
|
||||
(-> sl-store? (or/c symbol? regexp?) sl-store?)
|
||||
(let ((nq (copy-queue (sl-store-queue store)
|
||||
(λ (item)
|
||||
(let ((topic (sl-store-item-topic item)))
|
||||
(if (symbol? regexp)
|
||||
(eq? regexp topic)
|
||||
(regexp-match? regexp (symbol->string topic))))))))
|
||||
(make-sl-store* (sl-store-max-length store)
|
||||
(queue-length nq)
|
||||
nq)))
|
||||
|
||||
|
||||
(define/contract (sl-store-grep-message store regexp)
|
||||
(-> sl-store? regexp? sl-store?)
|
||||
(let ((nq (copy-queue (sl-store-queue store)
|
||||
(λ (item)
|
||||
(let ((msg (sl-store-item-message item)))
|
||||
(regexp-match? regexp msg))))))
|
||||
(make-sl-store* (sl-store-max-length store)
|
||||
(queue-length nq)
|
||||
nq)))
|
||||
|
||||
(define/contract (sl-store-grep store regexp)
|
||||
(-> sl-store? (or/c symbol? regexp?) sl-store?)
|
||||
(let ((lvl (hash-ref log-hash
|
||||
(if (regexp? regexp)
|
||||
(level-regexp->level regexp #f)
|
||||
(level-regexp->level (pregexp (symbol->string regexp)) #f))
|
||||
0)))
|
||||
(let ((nq (copy-queue (sl-store-queue store)
|
||||
(λ (item)
|
||||
(let ((topic (sl-store-item-topic item))
|
||||
(level (hash-ref log-hash (sl-store-item-level item) 0))
|
||||
(msg (sl-store-item-message item)))
|
||||
(and (>= level lvl)
|
||||
(or (if (symbol? regexp)
|
||||
(if (level? regexp)
|
||||
(or (>= level lvl) (eq? regexp topic))
|
||||
(eq? regexp topic))
|
||||
(regexp-match? regexp (symbol->string topic)))
|
||||
(if (symbol? regexp)
|
||||
#f
|
||||
(regexp-match? regexp msg)))))))))
|
||||
(make-sl-store* (sl-store-max-length store)
|
||||
(queue-length nq)
|
||||
nq))))
|
||||
|
||||
(define/contract (sl-store-tail store n)
|
||||
(-> sl-store? number? sl-store?)
|
||||
(let* ((q (sl-store-queue store))
|
||||
(from (if (>= n (queue-length q))
|
||||
0
|
||||
(- (queue-length q) n)))
|
||||
(i 0))
|
||||
(let ((nq (copy-queue q
|
||||
(λ (item)
|
||||
(if (>= i from)
|
||||
#t
|
||||
(begin
|
||||
(set! i (+ i 1))
|
||||
#f))))))
|
||||
(make-sl-store* (sl-store-max-length store) (queue-length nq) nq))))
|
||||
|
||||
|
||||
Reference in New Issue
Block a user