| ︙ | | | ︙ | |
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
|
;; PURPOSE.
;;======================================================================
;;======================================================================
;; Database access
;;======================================================================
(require-extension (srfi 18) extras tcp) ;; rpc)
;; (import (prefix rpc rpc:))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
;; Note, try to remove this dependency
;; (use zmq)
(declare (uses fs-transport))
|
|
<
<
<
<
<
<
|
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
|
;; PURPOSE.
;;======================================================================
;;======================================================================
;; Database access
;;======================================================================
(require-extension (srfi 18) extras tcp)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
|
| ︙ | | | ︙ | |
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
(string->number (args:get-arg "-override-timeout"))
136000))))
(handle-exceptions
exn
(begin
(debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
((condition-property-accessor 'exn 'message) exn))
(set! db (sqlite3:open-database ":memory:"))) ;; open an in-memory db to allow readonly access
(set! db (sqlite3:open-database dbpath)))
(if *db-write-access* (sqlite3:set-busy-handler! db handler))
(if (not dbexists)
(begin
(sqlite3:execute db "PRAGMA synchronous = FULL;")
(debug:print-info 11 "Initialized test database " dbpath)
(tdb:testdb-initialize db)))
|
|
>
|
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
(string->number (args:get-arg "-override-timeout"))
136000))))
(handle-exceptions
exn
(begin
(debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
((condition-property-accessor 'exn 'message) exn))
(set! db (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access
(set! dbexists #f)) ;; must force re-creation of tables, more tom-foolery
(set! db (sqlite3:open-database dbpath)))
(if *db-write-access* (sqlite3:set-busy-handler! db handler))
(if (not dbexists)
(begin
(sqlite3:execute db "PRAGMA synchronous = FULL;")
(debug:print-info 11 "Initialized test database " dbpath)
(tdb:testdb-initialize db)))
|
| ︙ | | | ︙ | |
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
|
(let* ((test-path (if work-area
work-area
(rmt:test-get-rundir-from-test-id test-id))))
(debug:print 3 "TEST PATH: " test-path)
(open-test-db test-path)))
;; find and open the testdat.db file for an existing test
(define (tdb:open-test-db-by-test-id-local test-id #!key (work-area #f))
(let* ((test-path (if work-area
work-area
(open-run-close db:test-get-rundir-from-test-id #f test-id))))
(debug:print 3 "TEST PATH: " test-path)
(open-test-db test-path)))
;; find and open the testdat.db file for an existing test
(define (tdb:open-run-close-db-by-test-id-local test-id work-area proc . params)
(let* ((test-path (if work-area
work-area
(open-run-close db:test-get-rundir-from-test-id #f test-id)))
(tdb (open-test-db test-path)))
(apply proc tdb params)))
(define (tdb:testdb-initialize db)
(debug:print 11 "db:testdb-initialize START")
(for-each
(lambda (sqlcmd)
|
|
|
|
|
|
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
|
(let* ((test-path (if work-area
work-area
(rmt:test-get-rundir-from-test-id test-id))))
(debug:print 3 "TEST PATH: " test-path)
(open-test-db test-path)))
;; find and open the testdat.db file for an existing test
(define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f))
(let* ((test-path (if work-area
work-area
(db:test-get-rundir-from-test-id dbstruct run-id test-id))))
(debug:print 3 "TEST PATH: " test-path)
(open-test-db test-path)))
;; find and open the testdat.db file for an existing test
(define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params)
(let* ((test-path (if work-area
work-area
(db:test-get-rundir-from-test-id dbstruct run-id test-id)))
(tdb (open-test-db test-path)))
(apply proc tdb params)))
(define (tdb:testdb-initialize db)
(debug:print 11 "db:testdb-initialize START")
(for-each
(lambda (sqlcmd)
|
| ︙ | | | ︙ | |
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
;; tdb
;; "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
;; (sqlite3:finalize! tdb)
;; (reverse res))
;; '())))
;; NOTE: Run this local with #f for db !!!
(define (tdb:load-test-data test-id)
(let loop ((lin (read-line)))
(if (not (eof-object? lin))
(begin
(debug:print 4 lin)
(rmt:csv->test-data test-id lin)
(loop (read-line)))))
;; roll up the current results.
;; FIXME: Add the status too
(rmt:test-data-rollup test-id #f))
(define (tdb:get-prev-tol-for-test tdb test-id category variable)
;; Finish me?
(values #f #f #f))
;;======================================================================
;; S T E P S
|
|
|
|
|
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
;; tdb
;; "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
;; (sqlite3:finalize! tdb)
;; (reverse res))
;; '())))
;; NOTE: Run this local with #f for db !!!
(define (tdb:load-test-data run-id test-id)
(let loop ((lin (read-line)))
(if (not (eof-object? lin))
(begin
(debug:print 4 lin)
(rmt:csv->test-data run-id test-id lin)
(loop (read-line)))))
;; roll up the current results.
;; FIXME: Add the status too
(rmt:test-data-rollup run-id test-id #f))
(define (tdb:get-prev-tol-for-test tdb test-id category variable)
;; Finish me?
(values #f #f #f))
;;======================================================================
;; S T E P S
|
| ︙ | | | ︙ | |
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
|
(if (eq? time-a time-b)
(string<? (conc (vector-ref a 2))
(conc (vector-ref b 2)))
#f))
(string<? (conc time-a)(conc time-b))))))))
;;
(define (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes)
(let ((tdb (tdb:open-test-db-by-test-id-local test-id work-area: work-area)))
(if (sqlite3:database? tdb)
(begin
(sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
cpuload diskfree minutes)
(sqlite3:finalize! tdb))
(debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant"))))
|
|
|
|
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
|
(if (eq? time-a time-b)
(string<? (conc (vector-ref a 2))
(conc (vector-ref b 2)))
#f))
(string<? (conc time-a)(conc time-b))))))))
;;
(define (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes)
(let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
(if (sqlite3:database? tdb)
(begin
(sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
cpuload diskfree minutes)
(sqlite3:finalize! tdb))
(debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant"))))
|