-

main.rkt

@@ -3,12 +3,16 @@
 (require (for-syntax racket/syntax)
          racket/date
          racket-sprintf
+         data/queue
          )
 
-(provide def-log
-         log-to
-         log-to-file
-         log-to-display
+(provide sl-def-log
+         sl-log-to
+         sl-log-to-file
+         sl-log-to-display
+         sl-log-to-file&display
+         sl-set-log-level
+         sl-log-level
          )
 
 (define (iso-timestamp)
@@ -21,6 +25,40 @@
             (date-minute d)
             (date-second d))))
 
+
+(define log-callbacks #f)
+(set! log-callbacks '())
+
+(define log-level #f)
+(set! log-level 'debug)
+
+(define max-log-queue-len 1000)
+(define log-queue (make-queue))
+
+(define (sl-set-log-level l)
+  (if (or
+       (eq? l 'debug)
+       (eq? l 'info)
+       (eq? l 'warning)
+       (eq? l 'warn)
+       (eq? l 'err)
+       (eq? l 'error)
+       (eq? l 'dbg)
+       (eq? l 'fatal))
+      (set! log-level
+            (cond
+              ((eq? l 'err) 'error)
+              ((eq? l 'warn) 'warning)
+              ((eq? l 'dbg) 'debug)
+              (else l)))
+      (error "Log level must be 'debug ('dbg), 'info, 'warning ('warn), 'error ('err) or 'fatal")
+      )
+  log-level
+  )
+
+(define (sl-log-level)
+  log-level)
+
 (define (log-to* receiver log-callbacks)
   (void
    (thread
@@ -31,11 +69,21 @@
                    (data (vector-ref v 2))
                    (dt (car data))
                    (topic (cadr data))
+                   (lc (log-callbacks))
                    )
-              (for-each (λ (e)
-                          (let ((callback (cdr e)))
-                            (callback topic level dt msg)))
-                        (log-callbacks))
+
+              (enqueue! log-queue (list topic level dt msg))
+              (unless (null? lc)
+                (for-each (λ (log-entry)
+                            (for-each (λ (e)
+                                        (let ((callback (cdr e)))
+                                          (apply callback log-entry)))
+                                      lc)
+                            )
+                          (queue->list log-queue))
+                (set! log-queue (make-queue)))
+              (when (> (queue-length log-queue) max-log-queue-len)
+                (dequeue! log-queue))
               )
             (loop)
             )
@@ -44,50 +92,56 @@
    )
   )
 
-(define-syntax (log-to stx)
-  (syntax-case stx ()
-    ((_ id name callback)
-     (with-syntax ([log-callbacks (format-id #'id "log-callbacks-~a" #'id)])
-       #'(set! log-callbacks (append
-                              (filter (λ (e)
-                                        (not (eq? (car e) 'name)))
-                                      log-callbacks) (list (cons 'name callback))))
-       )
+(define-syntax sl-log-to
+  (syntax-rules (log-callbacks)
+    ((_ name callback)
+     (set! log-callbacks (append
+                          (filter (λ (e) (not (eq? (car e) 'name)))
+                                  log-callbacks)
+                          (list (cons 'name callback)))
+           )
      )
     )
   )
 
-(define-syntax log-to-display
-  (syntax-rules (display)
-    ((_ id)
-     (log-to id display
-             (λ (topic level dt msg)
+(define (sl-log-to-file&display filename)
+  (log-to-display*)
+  (log-to-file* filename)
+  (dbg-simple-log "log to file and display enabled with file ~a" filename)
+  )
+
+(define (log-to-display*)
+  (sl-log-to display
+            (λ (topic level dt msg)
                (displayln (format "~a:~a:~a:~a" topic level dt msg)))
              )
-     )
-    )
+  )
+  
+
+(define (sl-log-to-display)
+  (log-to-display*)
+  (dbg-simple-log "log-to-display enabled")
   )
 
-(define-syntax log-to-file
-  (syntax-rules (file)
-    ((_ id filename)
+(define (log-to-file* filename)
      (let ((out (open-output-file filename #:exists 'replace)))
-       (log-to id file (λ (topic level dt msg)
-                         (displayln (format "~a:~a:~a:~a" topic level dt msg) out)
-                         (flush-output out))
-             )
+       (sl-log-to file (λ (topic level dt msg)
+                       (displayln (format "~a:~a:~a:~a" topic level dt msg) out)
+                       (flush-output out))
+               )
        )
-     )
-    )
   )
 
+(define (sl-log-to-file filename)
+  (log-to-file* filename)
+  (dbg-simple-log "log-to-file enabled with file ~a" filename)
+  )
 
 (define-syntax def-log2
   (syntax-rules ()
     ((_ id parent receiver log-callbacks dbgn infon warnn errn fataln)
      (begin
        (define l (make-logger 'id parent))
-       (define log-callbacks '())
        (define receiver (make-log-receiver l 'debug))
        (define (log level msg args)
          (log-message l level #f (apply format (cons msg args)) (list (iso-timestamp) 'id)))
@@ -103,23 +157,26 @@
   )
 
 
-(define-syntax (def-log stx)
-  (syntax-case stx ()
+(define-syntax (sl-def-log stx)
+  (syntax-case stx (log-callbacks)
     ((_ id parent)
      (with-syntax ([receiver (format-id #'id "receiver-~a" #'id)]
-                   [callbacks (format-id #'id "log-callbacks-~a" #'id)]
                    [dbg-name (format-id #'id "dbg-~a" #'id)]
                    [info-name (format-id #'id "info-~a" #'id)]
                    [warn-name (format-id #'id "warn-~a" #'id)]
                    [err-name (format-id #'id "err-~a" #'id)]
                    [fatal-name (format-id #'id "fatal-~a" #'id)]
                    )
-       #'(def-log2 id parent receiver callbacks dbg-name info-name warn-name err-name fatal-name)
+       #'(def-log2 id parent receiver log-callbacks dbg-name info-name warn-name err-name fatal-name)
        )
      )
     ((_ id)
-     #'(def-log id (current-logger))
+     #'(sl-def-log id (current-logger))
      )
     )
   )
 
+(sl-def-log simple-log)
+
+
+