source: project/release/3/logging/tags/1.1.0/logging-parameters.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: 6.0 KB
Line 
1;;;; logging-parameters.scm
2;;;; Kon Lovett, Sep '06
3
4(eval-when (compile)
5  (declare
6        (fixnum)
7        (inline)
8                (no-procedure-checks)
9                (no-bound-checks)
10        (export
11                default-mail-authority
12                logbook-uri-scheme-handler
13                current-logbook-format-procedure
14                        current-logbook-indent-amount
15                        #;default-file-permissions
16                default-asynchronous-error
17                        default-logbook
18                        default-logbook-entries
19                        default-logbook-sources
20                        default-logbook-fields
21                        default-logbook-entry
22                        default-logbook-source
23                        default-logbook-level
24                        default-logbook-directory
25                        default-logbook-extension
26                        default-logbook-echos
27                        default-logbook-alternates
28                        default-entry-level
29                        default-entry-fields
30                        default-logbook-catalog) ) )
31
32(use utils extras posix)
33(use miscmacros)
34
35;;;
36
37(include "logging-constants")
38(include "logging-record-types")
39(include "logging-argument-checking")
40
41;;;
42
43(define (atom-or-list-of pred)
44        (lambda (obj)
45                (if (list? obj)
46        (for-each pred obj)
47        (pred obj)) ) )
48
49;;;
50
51#;
52(define-parameter default-file-permissions
53  (bitwise-ior perm/irusr perm/iwusr perm/irgrp perm/iroth)
54        (lambda (x)
55                (if (fixnum? x)
56        x
57        (begin
58                (warning 'default-file-permissions "invalid parameter value" x)
59                (default-file-permissions) ) ) ) )
60
61(define-parameter default-asynchronous-error
62  (lambda (exp) exp)
63        (lambda (x)
64                (if (procedure? x)
65        x
66        (begin
67                (warning 'default-asynchronous-error "invalid parameter value" x)
68                (default-asynchronous-error) ) ) ) )
69
70(define-parameter current-logbook-format-procedure
71  (lambda (dest fstr . args) (apply format fstr args))
72        (lambda (x)
73                (if (procedure? x)
74        x
75        (begin
76                (warning 'current-logbook-format-procedure "invalid parameter value" x)
77          (current-logbook-format-procedure) ) ) ) )
78
79(define-parameter default-logbook
80  'none
81        (lambda (x)
82                (if (%log-argument? x)
83        x
84        (begin
85                (warning 'default-logbook "invalid parameter value" x)
86                (default-logbook) ) ) ) )
87
88(define-parameter current-logbook-indent-amount
89  DEFAULT-INDENT-AMOUNT
90        (lambda (x)
91                (if (and (fixnum? x) (<= 0 x) (< x MAXIMUM-INDENT-AMOUNT))
92        x
93        (begin
94                (warning 'current-logbook-indent-amount "invalid parameter value" x)
95          (current-logbook-indent-amount) ) ) ) )
96
97(define-parameter default-logbook-directory
98  #f
99        (lambda (x)
100                (if (%directory-argument? x)
101        x
102        (begin
103                (warning 'default-logbook-directory "invalid parameter value" x)
104                (default-logbook-directory) ) ) ) )
105
106(define-parameter default-logbook-extension
107  "log"
108        (lambda (x)
109                (if (%extension-argument? x)
110        x
111        (begin
112                (warning 'default-logbook-extension "invalid parameter value" x)
113                (default-logbook-extension) ) ) ) )
114
115(define-parameter default-logbook-entries
116  '()
117        (let ([pred (atom-or-list-of %entry-argument?)])
118                (lambda (x)
119                        (if (pred x)
120          x
121          (begin
122                (warning 'default-logbook-entries "invalid parameter value" x)
123                (default-logbook-entries) ) ) ) ) )
124
125(define-parameter default-logbook-sources
126  '()
127        (let ([pred (atom-or-list-of %source-argument?)])
128                (lambda (x)
129                        (if (pred x)
130          x
131          (begin
132                (warning 'default-logbook-sources "invalid parameter value" x)
133                (default-logbook-sources) ) ) ) ) )
134
135(define-parameter default-logbook-fields
136  '()
137        (let ([pred (atom-or-list-of field-value?)])
138                (lambda (x)
139                        (if (pred x)
140          x
141          (begin
142                (warning 'default-logbook-fields "invalid parameter value" x)
143                (default-logbook-fields) ) ) ) ) )
144
145(define-parameter default-logbook-entry
146  'none
147        (lambda (x)
148                (if (%entry-argument? x)
149        x
150        (begin
151                (warning 'default-logbook-entry "invalid parameter value" x)
152                (default-logbook-entry) ) ) ) )
153
154(define-parameter default-logbook-source
155  ""
156        (lambda (x)
157                (if (%source-argument? x)
158        x
159        (begin
160                (warning 'default-logbook-source "invalid parameter value" x)
161                (default-logbook-source) ) ) ) )
162
163(define-parameter default-logbook-level
164  ""
165        (lambda (x)
166                (if (%level-argument? x)
167        x
168        (begin
169                (warning 'default-logbook-level "invalid parameter value" x)
170                (default-logbook-level) ) ) ) )
171
172(define-parameter default-logbook-echos
173  '()
174        (let ([pred (atom-or-list-of %log-argument?)])
175                (lambda (x)
176                        (if (pred x)
177          x
178          (begin
179                (warning 'default-logbook-echos "invalid parameter value" x)
180                (default-logbook-echos) ) ) ) ) )
181
182(define-parameter default-logbook-alternates
183  '()
184        (let ([pred (atom-or-list-of %log-argument?)])
185                (lambda (x)
186                        (if (pred x)
187          x
188          (begin
189                (warning 'default-logbook-alternates "invalid parameter value" x)
190                (default-logbook-alternates) ) ) ) ) )
191
192(define-parameter default-entry-level
193  ""
194        (lambda (x)
195                (if (%level-argument? x)
196        x
197        (begin
198                (warning 'default-entry-level "invalid parameter value" x)
199                (default-entry-level) ) ) ) )
200
201(define-parameter default-entry-fields
202  '()
203        (let ([pred (atom-or-list-of field-value?)])
204                (lambda (x)
205                        (if (pred x)
206          x
207          (begin
208                (warning 'default-entry-fields "invalid parameter value" x)
209                (default-entry-fields) ) ) ) ) )
210
211(define-parameter default-logbook-catalog
212        (make-pathname (repository-path) LOGBOOK-CATALOG-FILENAME)
213        (lambda (x)
214                (if (string? x)
215        x
216        (begin
217                (warning 'default-logbook-catalog "invalid parameter value" x)
218                (default-logbook-catalog) ) ) ) )
219
220(define-parameter default-mail-authority
221  (list #f "" DEFAULT-SMTP-PORT)
222        (lambda (x)
223                (if (and (list? x) (= 3 (length x)))
224        x
225        (begin
226                (warning 'default-mail-authority "invalid parameter value" x)
227                (default-mail-authority) ) ) ) )
228
229;;;
230
231(define logbook-uri-scheme-handler
232        (let ([handlers '()])
233                (lambda (scheme #!optional proc)
234                        (if proc
235          (set! handlers (alist-update! scheme proc handlers eq?))
236          (alist-ref scheme handlers eq?) ) ) ) )
Note: See TracBrowser for help on using the repository browser.