216
217
218
219
220
221
222
223
224
225
226
227
228
229
|
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
|
+
+
+
+
|
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
;; Must do this *after* running patch db !! No more.
(db:set-var db "MEGATEST_VERSION" megatest-version)
))
;;======================================================================
;; T E S T S P E C I F I C D B
;;======================================================================
;; Create the sqlite db for the individual test(s)
(define (open-test-db testpath)
(if (and (directory? testpath)
(file-read-access? testpath))
(let* ((dbpath (conc testpath "/testdat.db"))
(dbexists (file-exists? dbpath))
(db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
|
285
286
287
288
289
290
291
292
293
294
295
296
297
298
|
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; the ackstate is set to 1 once the command has been completed
"CREATE TABLE IF NOT EXISTS test_meta (
id INTEGER PRIMARY KEY,
var TEXT,
val TEXT,
ackstate INTEGER DEFAULT 0,
CONSTRAINT metadat_constraint UNIQUE (var));")))
;;======================================================================
;; L O G G I N G D B
;;======================================================================
(define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
(dbexists (file-exists? dbpath))
(db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
36000)))) ;; 136000)))
(sqlite3:set-busy-handler! db handler)
(if (not dbexists)
(begin
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT);")
(sqlite3:execute db (conc "PRAGMA synchronous = 0;"))))
db))
(define (db:log-event . loglst)
(let ((db (open-logging-db))
(logline (apply conc loglst)))
(sqlite3:execute db "INSERT INTO log (logline) VALUES (?);" logline)
(sqlite3:finalize! db)
logline))
;;======================================================================
;; TODO:
;; put deltas into an assoc list with version numbers
;; apply all from last to current
;;======================================================================
(define (patch-db db)
|
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
|
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
|
-
+
|
(list fail-count pass-count test-id))
*incoming-data*))
(mutex-unlock! *incoming-mutex*)
(if *cache-on*
(debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write")
(db:write-cached-data)))
(define (cdb:tests-register-test db run-id test-name item-path #!key (force-write #f))
(define (cdb:tests-register-test run-id test-name item-path #!key (force-write #f))
(let ((item-paths (if (equal? item-path "")
(list item-path)
(list item-path ""))))
(debug:print 4 "INFO: Adding " run-id ", " test-name "/" item-path " for setting pass/fail counts to the queue")
(mutex-lock! *incoming-mutex*)
(set! *last-db-access* (current-seconds))
(set! *incoming-data* (cons (vector 'register-test
|
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
|
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
|
-
+
-
-
+
+
|
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'cdb:pass-fail-counts host port) test-id fail-count pass-count))
(cdb:pass-fail-counts test-id fail-count pass-count)))
;; currently forces a flush of the queue
(define (rdb:tests-register-test db run-id test-name item-path)
(define (rdb:tests-register-test run-id test-name item-path)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'cdb:tests-register-test host port) db run-id test-name item-path force-write: #t))
(cdb:tests-register-test db run-id test-name item-path force-write: #t)))
((rpc:procedure 'cdb:tests-register-test host port) run-id test-name item-path force-write: #t))
(cdb:tests-register-test run-id test-name item-path force-write: #t)))
(define (rdb:flush-queue)
(if *runremote*
(let ((host (vector-ref *runremote* 0))
(port (vector-ref *runremote* 1)))
((rpc:procedure 'cdb:flush-queue host port)))
(cdb:flush-queue)))
|