source: project/release/3/simple-logging/trunk/simple-logging.scm @ 18193

Last change on this file since 18193 was 18193, checked in by azul, 9 years ago

Don't log debug severity by default.

File size: 3.6 KB
Line 
1(declare
2  (export logging with-logging call-with-logging))
3
4(use posix format-modular)
5
6; List of severities in decending order:
7
8(define *severities*
9  (if (getenv "LOG_DEBUG")
10    '(fatal error warning info debug)
11    '(fatal error warning info)))
12
13(define *logging-data* #f)
14
15(define-record logging-data program-name directory files-list)
16(define-record logging-file file version byte-count)
17
18(define (get-log-path severity version)
19  (format #f "~A/~A-~A-~A"
20          (logging-data-directory *logging-data*)
21          severity
22          version
23          (current-seconds)))
24
25; TODO: Print the date in human readable form.
26
27(define (logging severity fmt . args)
28  (let ((str (format "~A: ~A: ~A: ~A"
29                     severity
30                     (seconds->string (current-seconds))
31                     (current-process-id)
32                     (apply format fmt args))))
33    ; We want to log this for the requested severity and all lesser:
34    (for-each
35      (lambda (s) (logging-with-severity s str))
36      (member severity *severities*))))
37
38(define (logging-proc severity proc fmt . args)
39  (let ((str (format #f fmt args)))
40    (lambda args
41      (call-with-logging severity (lambda () (apply proc args)) "~A" str))))
42
43(define (call-with-logging severity proc fmt . args)
44  (let ((id (gensym)) (str (apply format #f fmt args)))
45    (logging severity "> ~A: ~A" id str)
46    (let ((result (proc)))
47      (logging severity "< ~A: ~A" id str)
48      result)))
49
50(define *log-size*
51  (string->number (or (getenv "LOG_SIZE") "1048576")))
52
53(define (close-if-byte-count-would-be-exceeded file str)
54  ; If it would exceed the desired size, close it:
55  (when (and (positive? (logging-file-byte-count file))
56             (> (+ (logging-file-byte-count file) (string-length str) 1)
57                *log-size*))
58    (close-output-port (logging-file-file file))
59    (logging-file-file-set! file #f)))
60
61(define (open-logging-file file severity)
62  (unless (or (positive? (logging-file-version file))
63              (directory? (logging-data-directory *logging-data*)))
64    (create-directory (logging-data-directory *logging-data*)))
65  (logging-file-file-set! file
66    (open-output-file (get-log-path severity (logging-file-version file))))
67  (logging-file-byte-count-set! file 0)
68  (logging-file-version-set! file
69    (+ 1 (logging-file-version file))))
70
71(define (logging-with-severity severity str)
72  (let ((file (assoc severity (logging-data-files-list *logging-data*))))
73    (unless file
74      (set! file `(,severity ,(make-logging-file #f 0 0)))
75      (logging-data-files-list-set!
76        *logging-data*
77        (cons file (logging-data-files-list *logging-data*))))
78    (close-if-byte-count-would-be-exceeded (cadr file) str)
79    (unless (logging-file-file (cadr file))
80      (open-logging-file (cadr file) severity))
81    ; Log it and increase the byte count:
82    (write-line str (logging-file-file (cadr file)))
83    (logging-file-byte-count-set!
84      (cadr file)
85      (+ (string-length str) 1 (logging-file-byte-count (cadr file))))))
86
87(define (with-logging program-name thunk)
88  (set! *logging-data*
89    (make-logging-data
90      program-name
91      (format #f "~A/log-~A-~A-~A"
92              (or (getenv "TMPDIR")
93                  (getenv "TEMP")
94                  (getenv "TMP")
95                  "/tmp")
96              program-name
97              (current-seconds)
98              (current-process-id))
99      '()))
100  (thunk)
101  (for-each
102    (lambda (logging-file)
103      (when (logging-file-file (cadr logging-file))
104        (close-output-port (logging-file-file (cadr logging-file)))))
105    (logging-data-files-list *logging-data*)))
Note: See TracBrowser for help on using the repository browser.