︙ | | |
26
27
28
29
30
31
32
33
34
35
36
37
38
39
|
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
+
|
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses fs-transport))
(declare (uses client))
(declare (uses mt))
(declare (uses sdb))
(declare (uses filedb))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
|
︙ | | |
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
+
|
(else
(debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval)
#f))))
(if val
(begin
(debug:print-info 9 "db:set-sync, setting pragma synchronous to " val)
(sqlite3:execute db (conc "PRAGMA synchronous = '" val "';"))))))
;; (sqlite3:execute db "PRAGMA synchronous = normal;")))) ;; need a default?
;;======================================================================
;; K E E P F I L E D B I N dbstruct
;;======================================================================
(define (db:get-filedb dbstruct)
(let ((db (vector-ref dbstruct 2)))
|
︙ | | |
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
+
+
|
(sqlite3:open-database fname))
(sqlite3:open-database ":memory:")))
(handler (make-busy-timeout 3600)))
(if (or (not path)
(not exists))
(db:initialize db))
(sqlite3:set-busy-handler! db handler)
(set! sdb:qry (make-sdb:qry)) ;; we open the normalization helpers here
(set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
db))
;; (define (db:sync-table tblname fields fromdb todb)
(define (db:tbls db)
(let ((keys (db:get-keys db)))
(list
|
︙ | | |
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
|
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
|
-
+
|
run-id)
(debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(let ((finalres (vector header res)))
;; (hash-table-set! *run-info-cache* run-id finalres)
finalres)))
(define (db:set-comment-for-run dbstruct run-id comment)
(sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET comment=? WHERE id=?;" comment run-id))
(sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" (sdb:qry 'getid comment) run-id))
;; does not (obviously!) removed dependent data. But why not!!?
(define (db:delete-run dbstruct run-id)
;; First set any related tests to DELETED
(let ((db (db:get-db dbstruct run-id)))
(sqlite3:execute db "UPDATE tests SET state='DELETED',comment='';")
(sqlite3:execute db "DELETE FROM test_steps;")
|
︙ | | |
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
|
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
|
-
+
-
+
|
;; speed up for common cases with a little logic
;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
(define (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment)
(let ((db (db:get-db dbstruct run-id)))
(cond
((and newstate newstatus newcomment)
(sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id))
(sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus (sdb:qry 'getid newcomment) test-id))
((and newstate newstatus)
(sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
(else
(if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id))
(if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id))
(if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))
(if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" (sdb:qry 'getid newcomment) test-id))))
(mt:process-triggers test-id newstate newstatus)))
;; Never used, but should be?
(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
(sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;"
state status run-id test-name item-path))
|
︙ | | |
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
|
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
|
-
+
+
+
|
;; S T E P S
;;======================================================================
(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile)
(sqlite3:execute
db
"INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile "")))
test-id teststep-name state-in status-in (current-seconds)
(sdb:qry 'getid (if comment comment ""))
(sdb:qry 'getid (if logfile logfile ""))))
;; db-get-test-steps-for-run
(define (db:get-steps-for-test db test-id)
(let* ((res '()))
(sqlite3:for-each-row
(lambda (id test-id stepname state status event-time logfile)
(set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
|
︙ | | |
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
|
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
|
-
-
-
-
-
-
+
+
+
+
+
+
|
(define (db:tests-register-test dbstruct run-id test-name item-path)
(sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path))
(define (db:test-get-logfile-info dbstruct run-id test-name)
(let ((res #f))
(sqlite3:for-each-row
(lambda (path-id final_logf-id)
(let ((path (db:get-path dbstruct path-id))
(final_logf (db:get-string dbstruct final_logf-id)))
(set! logf final_logf)
(set! res (list path final_logf))
(if (directory? path)
(debug:print 2 "Found path: " path)
(let ((path (sdb:qry 'getstr path-id))
(final_logf (sdb:qry 'getstr final_logf-id)))
(set! logf final_logf)
(set! res (list path final_logf))
(if (directory? path)
(debug:print 2 "Found path: " path)
(debug:print 2 "No such path: " path))))
(db:get-db dbstruct run-id)
"SELECT rundir_id,final_logf_id FROM tests WHERE testname=? AND item_path='';"
test-name)
res))
;;======================================================================
|
︙ | | |