source: project/release/4/simple-logging/tags/17005.2/simple-logging.scm @ 29578

Last change on this file since 29578 was 29578, checked in by sjamaan, 7 years ago

Update simple-logging to 17005.2 so it can install again in the interest of cleaning out Trac (to close #798)

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 getenv get-environment-variable)
42
43(define (initialize-global-state program-name)
44  (cond
45    ((equal? (getenv "LOG_DIR") "")
46     (set! *logging-directory* #f))
47    (else
48     (set! *severities*
49       `((fatal #t)
50         (error #t)
51         (warning #t)
52         (info #t)
53         (debug ,(getenv "LOG_DEBUG"))))
54     (set! *logging-directory*
55       (format #f "~A/log-~A-~A-~A"
56         (get-logging-dir)
57         (or (getenv "LOG_PROGRAM") program-name)
58         (current-seconds)
59         (current-process-id)))
60     (set! *logs-to-keep* (string->number (or (getenv "LOG_COLLECT") "2")))
61     (set! *log-size* (string->number (or (getenv "LOG_SIZE") "1048576")))
62     (set! *log-files* '()))))
63
64(define (close-all-open-logs)
65  (when *logging-directory*
66    (for-each (compose close-output-port log-file-file cadr) *log-files*)))
67
68(define (get-logging-dir)
69  (or (getenv "LOG_DIR")
70      (getenv "TMPDIR")
71      (getenv "TEMP")
72      (getenv "TMP")
73      "/tmp"))
74
75(define (open-log-file severity file)
76  (assert *logging-directory*)
77  (condition-case (create-directory *logging-directory*) (e (exn) #f))
78  (when (and file (log-file-file file))
79    (close-output-port (log-file-file file))
80    (when (and (positive? *logs-to-keep*)
81               (>= (log-file-version file) *logs-to-keep*))
82      (condition-case (delete-file (log-file-path file)) (e (exn) #f))))
83  (let* ((version (if file (+ (log-file-version file) 1) 0))
84         (path (format #f "~A/~A-~A-~A"
85                       *logging-directory*
86                       severity
87                       version
88                       (current-seconds))))
89    (make-log-file (open-output-file path) 0 version path)))
90
91(define (logging-with-severity severity str)
92  (assert *logging-directory*)
93  (let ((file (assoc severity *log-files*)))
94    (define (get-new-length)
95      (+ (log-file-length (cadr file))
96         (string-length str)
97         (string-length "\n")))
98    (cond
99      ((not file)
100       (set! file `(,severity ,(open-log-file severity #f)))
101       (set! *log-files* (cons file *log-files*)))
102      ((> (get-new-length) *log-size*)
103       (set-car! (cdr file) (open-log-file severity (cadr file)))))
104    (assert file)
105    (assert (log-file? (cadr file)))
106    (assert (port? (log-file-file (cadr file))))
107    (write-line str (log-file-file (cadr file)))
108    (log-file-length-set! (cadr file) (get-new-length))))
109
110(define (log-call position severity proc fmt . args)
111  (if *logging-directory*
112    (let* ((id (gensym)) (str (format #f " ~A ~?" id fmt args)))
113      (log-str position severity ">~A" str)
114      (let ((result (proc)))
115        (log-str position severity "<~A" str)
116        result))
117    (proc)))
118
119(define (log-str position severity fmt . args)
120  (when *logging-directory*
121    (let ((str (format #f
122                       "~A: ~A: ~A: ~A: ~?"
123                       severity
124                       (or position "[unknown]")
125                       (seconds->string (current-seconds))
126                       (current-process-id)
127                       fmt
128                       args))
129          (severities (find-tail (lambda (s) (eq? (car s) severity))
130                                 *severities*)))
131      (cond
132        (severities
133         (for-each
134           (lambda (s)
135             (when (cadr s)
136               (logging-with-severity (car s) str)))
137           severities))
138        ((assoc 'warning *severities*)
139         (log-str position 'warning "Invalid logging severity: ~A: ~?" severity fmt args))))))
140
141(define (logging-proc position severity fmt . args)
142  (let ((result (apply (if (procedure? fmt) log-call log-str)
143                       position severity fmt args)))
144    (when (eq? severity 'fatal)
145      (exit 1))
146    result))
147
148(define-syntax (logging x r c)
149  (cons* (r 'logging-proc) (get-line-number x) (cdr x)))
150
151(define-syntax (log-fatal x r c) (cons* (r 'logging-proc) (get-line-number x) ''fatal (cdr x)))
152(define-syntax (log-error x r c) (cons* (r 'logging-proc) (get-line-number x) ''error (cdr x)))
153(define-syntax (log-warning x r c) (cons* (r 'logging-proc) (get-line-number x) ''warning (cdr x)))
154(define-syntax (log-info x r c) (cons* (r 'logging-proc) (get-line-number x) ''info (cdr x)))
155(define-syntax (log-debug x r c) (cons* (r 'logging-proc) (get-line-number x) ''debug (cdr x)))
156
157) ; end of module definition
Note: See TracBrowser for help on using the repository browser.