source: project/logging/logging-objects.scm @ 5447

Last change on this file since 5447 was 5447, checked in by Kon Lovett, 12 years ago

Chg for misc-extn 3.0

File size: 6.2 KB
Line 
1;;;; logging-objects.scm
2;;;; Kon Lovett, Sep '06
3
4(use srfi-18)
5(use lookup-table synch)
6(use logging-errors logging-catalogs)
7
8(eval-when (compile)
9  (declare
10        (usual-integrations)
11        (fixnum)
12        (inline)
13                (no-procedure-checks)
14                (no-bound-checks)
15        (export
16                        logbook-source
17                        logbook-field
18                        logbook-level
19                        logbook-entry
20                        logbook
21                        logbook-source-add!
22                        logbook-field-add!
23                        logbook-level-add!
24                        logbook-entry-add!
25                        logbook-add!
26                        logbook-source-delete!
27                        logbook-field-delete!
28                        logbook-level-delete!
29                        logbook-entry-delete!
30                        logbook-delete!) ) )
31
32;;;
33
34(include "logging-record-types")
35
36;;; Argument Checking
37
38;;
39
40(define (%source-argument? obj)
41        (or (symbol? obj) (string? obj)) )
42
43(define (%level-argument? obj)
44        (or (%level? obj) (symbol? obj) (string? obj)) )
45
46(define (%entry-argument? obj)
47        (or (%entry? obj) (symbol? obj)) )
48
49(define (%log-argument? obj)
50        (or (%log? obj) (symbol? obj)) )
51
52;;
53
54(define (check-source obj loc)
55        (unless (%source? obj)
56                (log$error loc "invalid logbook source" obj)) )
57
58(define (check-level obj loc)
59        (unless (%level? obj)
60                (log$error loc "invalid logbook level" obj)) )
61
62(define (check-entry obj loc)
63        (unless (%entry? obj)
64                (log$error loc "invalid logbook entry" obj)) )
65
66(define (check-log obj loc)
67        (unless (%log? obj)
68                (log$error loc "invalid logbook" obj)) )
69
70(define (check-field obj loc)
71        (unless (field-value? obj)
72                (log$error loc "invalid logbook field" obj)) )
73
74;;
75
76(define (check-source-argument obj loc)
77        (unless (%source-argument? obj)
78                (log$error loc "invalid logbook source" obj)) )
79
80(define (check-level-argument obj loc)
81        (unless (%level-argument? obj)
82                (log$error loc "invalid logbook level" obj)) )
83
84(define (check-entry-argument obj loc)
85        (unless (%entry-argument? obj)
86                (log$error loc "invalid logbook entry" obj)) )
87
88(define (check-log-argument obj loc)
89        (unless (%log-argument? obj)
90                (log$error loc "invalid logbook" obj)) )
91
92;;; Catalog Cross-Reference Checking
93
94(define (check-log-catalog-source-unreferenced source loc)
95        (log$log-catalog-for-each
96                (lambda (k l)
97                        (synch/log l
98                                (when (memq source (%log-sources l))
99                                        (log$error loc "source in use" source) ) ) ) ) )
100
101(define (check-log-catalog-level-unreferenced level loc)
102        (log$log-catalog-for-each
103                (lambda (k l)
104                        (synch/log l
105                                (when (eq? level (%log-level l))
106                                        (log$error loc "level in use" level) ) ) ) ) )
107
108(define (check-log-catalog-entry-unreferenced entry loc)
109        (log$log-catalog-for-each
110                (lambda (k l)
111                        (synch/log l
112                                (when (eq? entry (%log-entry l))
113                                        (log$error loc "entry in use" entry) ) ) ) ) )
114
115(define (check-log-catalog-log-unreferenced log loc)
116        (log$log-catalog-for-each
117                (lambda (k l)
118                        (synch/log l
119                                (when (or (memq log (%log-echos l)) (memq log (%log-alternates l)))
120                                        (log$error loc "log in use" log) ) ) ) ) )
121
122(define (check-entry-catalog-field-unreferenced field loc)
123        (log$entry-catalog-for-each
124                (lambda (k e)
125                        (synch/entry e
126                                (when (memq field (%entry-fields e))
127                                        (log$error loc "field in use" field) ) ) ) ) )
128
129(define (check-entry-catalog-level-unreferenced level loc)
130        (log$entry-catalog-for-each
131                (lambda (k e)
132                        (synch/entry e
133                                (when (eq? level (%entry-level e))
134                                        (log$error loc "level in use" level) ) ) ) ) )
135
136;;; Reference Logger Objects From Catalog
137
138(define (logbook-source source)
139        (check-source-argument source 'logbook-source)
140        (log$catalog-value log$source-catalog->source source) )
141
142(define (logbook-field field)
143        (check-field field 'logbook-field)
144        (log$catalog-value log$field-catalog->field field) )
145
146(define (logbook-level level)
147        (check-level-argument level 'logbook-level)
148        (log$catalog-value log$level-catalog->level level) )
149
150(define (logbook-entry entry)
151        (check-entry-argument entry 'logbook-entry)
152        (log$catalog-value log$entry-catalog->entry entry) )
153
154(define (logbook log)
155        (check-log-argument log 'logbook)
156        (log$catalog-value log$log-catalog->log log) )
157
158;;; Add Logger Objects To Catalog
159
160(define (logbook-source-add! source)
161        (check-source source 'logbook-source-add!)
162        (log$catalog-add! log$source-catalog->source
163                (%source-id source) source 'logbook-source-add!) )
164
165(define (logbook-field-add! field)
166        (check-field field 'logbook-field-add!)
167        (log$catalog-add! log$field-catalog->field
168                (%field-id field) field 'logbook-field-add!) )
169
170(define (logbook-level-add! level)
171        (check-level level 'logbook-level-add!)
172        (log$catalog-add! log$level-catalog->level
173                (%level-id level) level 'logbook-level-add!) )
174
175(define (logbook-entry-add! entry)
176        (check-entry entry 'logbook-entry-add!)
177        (log$catalog-add! log$entry-catalog->entry
178                (%entry-id entry) entry 'logbook-entry-add!) )
179
180(define (logbook-add! log)
181        (check-log log 'logbook-add!)
182        (log$catalog-add! log$log-catalog->log
183                (%log-id log) log 'logbook-add!) )
184
185;;; Delete Logger Objects From Catalog
186
187(define (logbook-source-delete! source)
188        (check-source-argument source 'logbook-source-delete!)
189        (let ([obj (log$catalog-value log$source-catalog->source source)])
190                (check-log-catalog-source-unreferenced obj 'logbook-source-delete!)
191                (log$catalog-delete! log$source-catalog->source obj) ) )
192
193(define (logbook-field-delete! field)
194        (check-field field 'logbook-field-delete!)
195        (let ([obj (log$catalog-value log$field-catalog->field field)])
196                (check-entry-catalog-field-unreferenced obj 'logbook-field-delete!)
197                (log$catalog-delete! log$field-catalog->field obj) ) )
198
199(define (logbook-level-delete! level)
200        (check-level-argument level 'logbook-level-delete!)
201        (when (or (eq? 'off level) (eq? 'all level))
202                (log$error 'logbook-level-delete! "cannot delete reserved level" level) )
203        (let ([obj (log$catalog-value log$level-catalog->level level)])
204                (check-log-catalog-level-unreferenced obj 'logbook-level-delete!)
205                (check-entry-catalog-level-unreferenced obj 'logbook-level-delete!)
206                (log$catalog-delete! log$level-catalog->level obj) ) )
207
208(define (logbook-entry-delete! entry)
209        (check-entry-argument entry 'logbook-entry-delete!)
210        (let ([obj (log$catalog-value log$entry-catalog->entry entry)])
211                (check-log-catalog-entry-unreferenced obj 'logbook-entry-delete!)
212                (log$catalog-delete! log$entry-catalog->entry obj) ) )
213
214(define (logbook-delete! log)
215        (check-log-argument log 'logbook-delete!)
216        (let ([obj (log$catalog-value log$log-catalog->log log)])
217                (check-log-catalog-log-unreferenced obj 'logbook-delete!)
218                (log$catalog-delete! log$log-catalog->log obj) ) )
Note: See TracBrowser for help on using the repository browser.