Added a store to simple-log.

main.rkt

@@ -5,16 +5,20 @@
          racket-sprintf
          racket/async-channel
          data/queue
+         "private/loghash.rkt"
+         "private/store.rkt"
          )
 
 (provide sl-def-log
          sl-log-to
          sl-log-to-file
          sl-log-to-display
+         sl-log-to-store
          sl-log-to-file&display
          sl-set-log-level
          sl-log-level
          sl-sync
+         (all-from-out "private/store.rkt")
          )
 
 (define (iso-timestamp)
@@ -72,11 +76,7 @@
 (define (sl-log-level)
   log-level)
 
-(define log-hash (hash 'debug 0 'dbg 0
+
-                       'info 1
-                       'warning 2 'warn 2
-                       'err 3 'error 3
-                       'fatal 5))
 
 (define (needs-logging level)
   (let ((ll (hash-ref log-hash log-level 6))
@@ -189,6 +189,14 @@
   (dbg-simple-log "log-to-display enabled")
   )
 
+(define (sl-log-to-store [max-length 1000])
+  (let ((st (make-sl-store max-length)))
+    (sl-log-to store
+               (λ (topic level dt msg)
+                 (sl-store-enqueue! st topic level dt msg)))
+    (dbg-simple-log "log to store enabled")
+    st))
+
 (define (log-to-file* filename)
      (let ((out (open-output-file filename #:exists 'replace)))
        (sl-log-to file (λ (topic level dt msg)
@@ -250,4 +258,13 @@
 (sl-def-log simple-log)
 
 
-
+(define (sl-store-test)
+  (sl-def-log test)
+  (dbg-test "Dit is debug bericht 1")
+  (info-test "Dit is info bericht 1")
+  (info-test "Dit is info bericht 2")
+  (err-test "Dit is een foutbericht")
+  (err-test "Dit is nog een foutbericht")
+  (fatal-test "JA!")
+  (dbg-test "Oke, nog een debug bericht")
+  )

private/loghash.rkt

@@ -0,0 +1,9 @@
+#lang racket
+
+(provide log-hash)
+
+(define log-hash (hash 'debug 0 'dbg 0
+                       'info 1
+                       'warning 2 'warn 2
+                       'err 3 'error 3
+                       'fatal 5))

private/store.rkt

@@ -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))))
+  
+