source: project/release/3/logging/tags/1.1.0/logging-catalogs.scm @ 9139

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

Fix for e-mail uri query processing. Cosmetic chgs.

File size: 3.6 KB
Line 
1;;;; logging-catalogs.scm
2;;;; Kon Lovett, Sep '06
3
4(eval-when (compile)
5  (declare
6                (usual-integrations)
7        (fixnum)
8        (inline)
9        (export
10                log$empty-catalog
11                log$fill-catalog
12                        log$source-catalog->source
13                        log$field-catalog->field
14                        log$level-catalog->level
15                        log$entry-catalog->entry
16                        log$log-catalog->log
17                        log$catalog-value
18                        log$catalog-key
19                        log$catalog-ref
20                        log$catalog-add!
21                        log$catalog-set!
22                        log$catalog-delete!
23                log$source-catalog-for-each
24                log$field-catalog-for-each
25                log$level-catalog-for-each
26                log$entry-catalog-for-each
27                log$log-catalog-for-each) ) )
28
29(use srfi-18 utils)
30(use lookup-table synch miscmacros)
31(use logging-errors)
32
33;;; Catalog Support
34
35;; Lookup entry by symbol id or actual value
36
37(define (catalog-key/value cat key)
38        (%let/synch ([dict cat])
39                (if (symbol? key)
40        (values
41          key
42          (dict-ref dict key))
43        (values
44          (dict-search dict
45            (lambda (id value)
46              (and (equal? key value)
47                   (begin (set! key id) #t))))
48          key) ) ) )
49
50(define (log$catalog-value cat key)
51        (let-values (([id obj] (catalog-key/value cat key)))
52                (and id
53                     obj) ) )
54
55(define (log$catalog-key cat key)
56        (let-values (([id obj] (catalog-key/value cat key)))
57                (and obj
58                     id) ) )
59
60(define (log$catalog-ref cat key)
61        (%let/synch ([dict cat])
62                (dict-ref dict key) ) )
63
64(define (log$catalog-add! cat key value loc)
65        (let/synch ([dict cat])
66                (if (dict-ref dict key)
67        (log$error loc "identifier in use" key)
68        (dict-set! dict key value)) ) )
69
70(define (log$catalog-set! cat key value loc)
71        (%let/synch ([dict cat])
72                (dict-set! dict key value) ) )
73
74(define (log$catalog-delete! cat key)
75        ; Can remove from a catalog even if object in use
76        (%let/synch ([dict cat])
77                (dict-delete! dict key) ) )
78
79(define-constant INITIAL-CATALOG-SIZE 1)
80
81(define (make-catalog/synch id #!optional (dict (make-dict INITIAL-CATALOG-SIZE eq?)))
82        (make-object/synch dict id) )
83
84;;; Logger Catalog
85
86;; There is only one
87
88(define log$source-catalog->source #f)
89(define log$field-catalog->field #f)
90(define log$level-catalog->level #f)
91(define log$entry-catalog->entry #f)
92(define log$log-catalog->log #f)
93
94(define (log$empty-catalog)
95        (set! log$source-catalog->source (make-catalog/synch 'source-catalog->source))
96        (set! log$field-catalog->field (make-catalog/synch 'field-catalog->field))
97        (set! log$level-catalog->level (make-catalog/synch 'level-catalog->level))
98        (set! log$entry-catalog->entry (make-catalog/synch 'entry-catalog->entry))
99        (set! log$log-catalog->log (make-catalog/synch 'log-catalog->log)) )
100
101(define (log$fill-catalog sources fields levels entries logs)
102        (set! log$source-catalog->source
103                (make-catalog/synch 'source-catalog->source sources))
104        (set! log$field-catalog->field
105                (make-catalog/synch 'field-catalog->field fields))
106        (set! log$level-catalog->level
107                (make-catalog/synch 'level-catalog->level levels))
108        (set! log$entry-catalog->entry
109                (make-catalog/synch 'entry-catalog->entry entries))
110        (set! log$log-catalog->log
111                (make-catalog/synch 'log-catalog->log logs)) )
112
113;;;
114
115(define (catalog-for-each cat proc)
116        (let/synch ([dict cat])
117                (dict-for-each dict proc) ) )
118
119(define (log$source-catalog-for-each proc)
120        (catalog-for-each log$source-catalog->source proc) )
121
122(define (log$field-catalog-for-each proc)
123        (catalog-for-each log$field-catalog->field proc) )
124
125(define (log$level-catalog-for-each proc)
126        (catalog-for-each log$level-catalog->level proc) )
127
128(define (log$entry-catalog-for-each proc)
129        (catalog-for-each log$entry-catalog->entry proc) )
130
131(define (log$log-catalog-for-each proc)
132        (catalog-for-each log$log-catalog->log proc) )
133
Note: See TracBrowser for help on using the repository browser.