1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
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
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
;; NOTE: This is the db module, long term it will replace db.scm.
;; WARN: This module conflicts with db.scm as it uses sql-de-lite
(declare (unit common))
(module common
(
get-create-writeable-dir
print-error
print-info
log-event
debug-setup
debug-mode
check-verbosity
calc-verbosity
)
(import scheme chicken data-structures extras posix ports)
(use (prefix sql-de-lite sql:) posix typed-records format srfi-1 srfi-69)
(defstruct ctrldat
(port (current-error-port))
(verbosity 1)
(vcache (make-hash-table))
(logging #f) ;; keep the flag and the db handle separate to enable overriding
(logdb #f) ;; might need to make this a stack of handles for threaded access
(toppath #f) ;;
)
(define *log* (make-ctrldat))
;; 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 (calc-verbosity vstr args)
(or (hash-table-ref/default (ctrldat-vcache *log*) vstr #f)
(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))))
((hash-table-exists? args "-v") 2)
((hash-table-exists? args "-q") 0)
(else 1))))
(hash-table-set! (ctrldat-vcache *log*) vstr res)
res)))
;; check verbosity, #t is ok
(define (check-verbosity verbosity vstr)
(if (not (or (number? verbosity)
(list? verbosity)))
(begin
(print "ERROR: Invalid debug value \"" vstr "\"")
#f)
#t))
(define (debug-mode n)
(let* ((verbosity (ctrldat-verbosity *log*)))
(cond
((and (number? verbosity) ;; number number
(number? n))
(<= n verbosity))
((and (list? verbosity) ;; list number
(number? n))
(member n verbosity))
((and (list? verbosity) ;; list list
(list? n))
(not (null? (lset-intersection! eq? verbosity n))))
((and (number? verbosity)
(list? n))
(member verbosity n)))))
(define (debug-setup args)
(let* ((debugstr (or (hash-table-ref/default args "-debug" #f)
(get-environment-variable "MT_DEBUG_MODE")))
(verbosity (calc-verbosity debugstr args)))
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not (check-verbosity verbosity debugstr))
(set! verbosity 1))
(ctrldat-verbosity-set! *log* verbosity)
(if (or (hash-table-exists? args "-debug")
(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-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
(if (ctrldat-logging *log*)
(log-event (apply conc params))
(apply print params)
)))))
;; ;; Brandon's debug printer shortcut (indulge me :)
;; (define *BB-process-starttime* (current-milliseconds))
;; (define (BB> . in-args)
;; (let* ((stack (get-call-chain))
;; (location "??"))
;; (for-each
;; (lambda (frame)
;; (let* ((this-loc (vector-ref frame 0))
;; (temp (string-split (->string this-loc) " "))
;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
;; (if (equal? this-func "BB>")
;; (set! location this-loc))))
;; stack)
;; (let* ((color-on "\x1b[1m")
;; (color-off "\x1b[0m")
;; (dp-args
;; (append
;; (list 0 *default-log-port*
;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
;; in-args)))
;; (apply debug:print dp-args))))
;;
;; (define *BBpp_custom_expanders_list* (make-hash-table))
;;
;;
;;
;; ;; register hash tables with BBpp.
;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
;; (cons hash-table? hash-table->alist))
;;
;; ;; test name converter
;; (define (BBpp_custom_converter arg)
;; (let ((res #f))
;; (for-each
;; (lambda (custom-type-name)
;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
;; (custom-type-test (car custom-type-info))
;; (custom-type-converter (cdr custom-type-info)))
;; (when (and (not res) (custom-type-test arg))
;; (set! res (custom-type-converter arg)))))
;; (hash-table-keys *BBpp_custom_expanders_list*))
;; (if res (BBpp_ res) arg)))
;;
;; (define (BBpp_ arg)
;; (cond
;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
;; ((hash-table? arg)
;; (let ((al (hash-table->alist arg)))
;; (BBpp_ (cons HASH_TABLE: al))))
;; ((null? arg) '())
;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;; (else (BBpp_custom_converter arg))))
;;
;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
;; (define (BBpp arg)
;; (pp (BBpp_ arg)))
;;
;; ;(use define-macro)
;; (define-syntax inspect
;; (syntax-rules ()
;; [(_ x)
;; ;; (with-output-to-port (current-error-port)
;; (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
;; ;; )
;; ]
;; [(_ x y ...) (begin (inspect x) (inspect y ...))]))
(define (print-error n e . params)
;; normal print
(if (debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
(if (ctrldat-logging *log*)
(log-event (apply conc params))
;; (apply print "pid:" (current-process-id) " " params)
(apply print "ERROR: " params)
))))
;; pass important messages to stderr
(if (and (eq? n 0)(not (eq? e (current-error-port))))
(with-output-to-port (current-error-port)
(lambda ()
(apply print "ERROR: " params)
))))
(define (print-info n e . params)
(if (debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
(if (ctrldat-logging *log*)
(let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
(log-event res))
(apply print "INFO: (" n ") " params) ;; res)
)))))
;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
(if (or (number? val)(string? val)) val ""))
;;======================================================================
;; L O G G I N G D B
;;======================================================================
(define (open-logging-db toppath)
(let* ((dbpath (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname)
(dbexists (file-exists? dbpath))
(db (sql:open-database dbpath))
(handler (sql:busy-timeout 136000))) ;; remove argument to override
(sql:set-busy-handler! db handler)
(if (not dbexists)
(sql:exec (sql:sql db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")))
(sql:exec (sql:sql db "PRAGMA synchronous = 0;"))
db))
(define (log-local-event toppath . loglst)
(let ((logline (apply conc loglst)))
(log-event logline)))
(define (log-event toppath logline)
(let ((db (open-logging-db toppath)))
(sql:exec
(sql:sql db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);")
logline
(current-directory)
(string-intersperse (argv) " ")
(current-process-id))
logline))
;;======================================================================
;; paths and directories
;;======================================================================
;; return first path that can be created or already exists and is writable
;;
(define (get-create-writeable-dir dirs)
(if (null? dirs)
#f
(let loop ((hed (car dirs))
(tal (cdr dirs)))
(let ((res (or (and (directory? hed)
(file-write-access? hed)
hed)
(handle-exceptions
exn
(begin
;; (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.")
(print "INFO: could not create " hed ", this might cause problems down the road.")
#f)
(create-directory hed #t)))))
(if (and (string? res)
(directory? res))
res
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
(define old-file-exists? file-exists?)
(define (file-exists? path-string)
;; this avoids stack dumps. NOTE: The issues that triggered this approach might have been fixed TODO: test and remove if possible
;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
(handle-exceptions
exn
#f
(file-exists? path-string)))
)
|