source: project/release/4/simple-logging/tags/17005.1/simple-logging.scm @ 25943

Last change on this file since 25943 was 18745, checked in by azul, 10 years ago

importing

File size: 5.2 KB
Line 
1; FILE AUTOMATICALLY GENERATED!
2;
3; This file was automatically generated by the svnwiki-scheme-library extension.
4; The authoritative source for this is:
5;
6;   http://wiki.freaks-unidos.net/weblogs/azul/simple-logging
7;
8; Generation data:
9;
10;   Input revision: 17005
11;   User: www-data
12;   Machine: mononykus.freaks-unidos.net
13;   Date: Wed Jul  7 23:18:14 2010
14
15(module simple-logging ((logging logging-proc) with-logging get-logging-dir (log-fatal logging-proc) (log-error logging-proc) (log-warning logging-proc) (log-info logging-proc) (log-debug logging-proc))
16
17
18(import scheme chicken)
19(use posix extras srfi-1 data-structures format-compiler)
20
21(define *logging-directory* #f)
22
23(define *severities* #f)
24
25(define *logging-program-name* #f)
26
27(define *logs-to-keep* #f)
28
29(define *log-size* #f)
30
31(define *log-files* #f)
32
33(define-record log-file file version length path)
34
35(define (with-logging program-name thunk)
36  (initialize-global-state program-name)
37  (let ((result (thunk)))
38    (close-all-open-logs)
39    result))
40
41(define (initialize-global-state program-name)
42  (cond
43    ((equal? (getenv "LOG_DIR") "")
44     (set! *logging-directory* #f))
45    (else
46     (set! *severities*
47       `((fatal #t)
48         (error #t)
49         (warning #t)
50         (info #t)
51         (debug ,(getenv "LOG_DEBUG"))))
52     (set! *logging-directory*
53       (format #f "~A/log-~A-~A-~A"
54         (get-logging-dir)
55         (or (getenv "LOG_PROGRAM") program-name)
56         (current-seconds)
57         (current-process-id)))
58     (set! *logs-to-keep* (string->number (or (getenv "LOG_COLLECT") "2")))
59     (set! *log-size* (string->number (or (getenv "LOG_SIZE") "1048576")))
60     (set! *log-files* '()))))
61
62(define (close-all-open-logs)
63  (when *logging-directory*
64    (for-each (compose close-output-port log-file-file cadr) *log-files*)))
65
66(define (get-logging-dir)
67  (or (getenv "LOG_DIR")
68      (getenv "TMPDIR")
69      (getenv "TEMP")
70      (getenv "TMP")
71      "/tmp"))
72
73(define (open-log-file severity file)
74  (assert *logging-directory*)
75  (condition-case (create-directory *logging-directory*) (e (exn) #f))
76  (when (and file (log-file-file file))
77    (close-output-port (log-file-file file))
78    (when (and (positive? *logs-to-keep*)
79               (>= (log-file-version file) *logs-to-keep*))
80      (condition-case (delete-file (log-file-path file)) (e (exn) #f))))
81  (let* ((version (if file (+ (log-file-version file) 1) 0))
82         (path (format #f "~A/~A-~A-~A"
83                       *logging-directory*
84                       severity
85                       version
86                       (current-seconds))))
87    (make-log-file (open-output-file path) 0 version path)))
88
89(define (logging-with-severity severity str)
90  (assert *logging-directory*)
91  (let ((file (assoc severity *log-files*)))
92    (define (get-new-length)
93      (+ (log-file-length (cadr file))
94         (string-length str)
95         (string-length "\n")))
96    (cond
97      ((not file)
98       (set! file `(,severity ,(open-log-file severity #f)))
99       (set! *log-files* (cons file *log-files*)))
100      ((> (get-new-length) *log-size*)
101       (set-car! (cdr file) (open-log-file severity (cadr file)))))
102    (assert file)
103    (assert (log-file? (cadr file)))
104    (assert (port? (log-file-file (cadr file))))
105    (write-line str (log-file-file (cadr file)))
106    (log-file-length-set! (cadr file) (get-new-length))))
107
108(define (log-call position severity proc fmt . args)
109  (if *logging-directory*
110    (let* ((id (gensym)) (str (format #f " ~A ~?" id fmt args)))
111      (log-str position severity ">~A" str)
112      (let ((result (proc)))
113        (log-str position severity "<~A" str)
114        result))
115    (proc)))
116
117(define (log-str position severity fmt . args)
118  (when *logging-directory*
119    (let ((str (format #f
120                       "~A: ~A: ~A: ~A: ~?"
121                       severity
122                       (or position "[unknown]")
123                       (seconds->string (current-seconds))
124                       (current-process-id)
125                       fmt
126                       args))
127          (severities (find-tail (lambda (s) (eq? (car s) severity))
128                                 *severities*)))
129      (cond
130        (severities
131         (for-each
132           (lambda (s)
133             (when (cadr s)
134               (logging-with-severity (car s) str)))
135           severities))
136        ((assoc 'warning *severities*)
137         (log-str position 'warning "Invalid logging severity: ~A: ~?" severity fmt args))))))
138
139(define (logging-proc position severity fmt . args)
140  (let ((result (apply (if (procedure? fmt) log-call log-str)
141                       position severity fmt args)))
142    (when (eq? severity 'fatal)
143      (exit 1))
144    result))
145
146(define-syntax (logging x r c)
147  (cons* (r 'logging-proc) (get-line-number x) (cdr x)))
148
149(define-syntax (log-fatal x r c) (cons* (r 'logging-proc) (get-line-number x) ''fatal (cdr x)))
150(define-syntax (log-error x r c) (cons* (r 'logging-proc) (get-line-number x) ''error (cdr x)))
151(define-syntax (log-warning x r c) (cons* (r 'logging-proc) (get-line-number x) ''warning (cdr x)))
152(define-syntax (log-info x r c) (cons* (r 'logging-proc) (get-line-number x) ''info (cdr x)))
153(define-syntax (log-debug x r c) (cons* (r 'logging-proc) (get-line-number x) ''debug (cdr x)))
154
155) ; end of module definition
Note: See TracBrowser for help on using the repository browser.