19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
-
+
|
;;======================================================================
(declare (unit commonmod))
(module commonmod
*
(import scheme chicken data-structures extras files)
(import scheme chicken data-structures extras files ports)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
md5 message-digest
regex srfi-1)
;;======================================================================
;; CONTENTS
;;
|
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;
(define (get-cfg-areas cfgdat)
(let ((adat (get-section cfgdat "areas")))
(map (lambda (entry)
`(,(car entry) .
,(val->alist (cadr entry))))
adat)))
;;======================================================================
;; debug stuff
;;======================================================================
(define verbosity (make-parameter '()))
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;;
;; (define (set-functions dbgp dbgpinfo)
;; (set! debug:print dbgp)
;; (set! debug:print-info dbgpinfo))
;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug-calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet)
(let* ((res (cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
(cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
((eq? arg 'v) 2) ;; verbose
((eq? arg 'q) 0) ;; quiet
(else 1))))
(verbosity res)
res))
)
;; check verbosity, #t is ok
#;(define (debug-check-verbosity verbosity vstr)
(if (not (or (number? verbosity)
(list? verbosity)))
(begin
(print "ERROR: Invalid debug value \"" vstr "\"")
#f)
#t))
(define (debug-debug-mode n)
(let* ((vb (verbosity)))
(cond
((and (number? vb) ;; number number
(number? n))
(<= n vb))
((and (list? vb) ;; list number
(number? n))
(member n vb))
((and (list? vb) ;; list list
(list? n))
(not (null? (lset-intersection! eq? vb n))))
((and (number? vb)
(list? n))
(member vb n)))))
(define (debug-setup debug-arg) ;; debug-arg= #f, #t or 'noprop
(let ((debugstr (or debug-arg ;; (args:get-arg "-debug")
;; (args:get-arg "-debug-noprop")
(get-environment-variable "MT_DEBUG_MODE"))))
(debug-calc-verbosity debugstr)
;; (debug:check-verbosity *verbosity* debugstr)
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not (verbosity))(set! (verbosity) 1))
(if (and (not (eq? debug-arg 'noprop))
(or debug-arg
(not (get-environment-variable "MT_DEBUG_MODE"))))
(setenv "MT_DEBUG_MODE" (if (list? (verbosity))
(string-intersperse (map conc (verbosity)) ",")
(conc (verbosity)))))))
(define (debug-print n e . params)
(if (debug-debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
;; (if *logging*
;; (db:log-event (apply conc params))
(apply print params)
)))) ;; )
)
|