| ︙ | | | ︙ | |
13
14
15
16
17
18
19
20
21
22
23
24
25
26
|
;; 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:))
(import (prefix dbi dbi:))
(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
|
>
|
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
|
;; 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:))
(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm")
(import (prefix dbi dbi:))
(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
|
| ︙ | | | ︙ | |
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
|
(set! dbdat (cons (cons 'dbname ":memory:") dbdat)))))
(tdb-writeable (and (file-write-access? work-area)
(file-write-access? dbpath)))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000))))
(if (and tdb-writeable
*db-write-access*)
(sqlite3:set-busy-handler! db handler))
(if (not dbexists)
(begin
(db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
(debug:print-info 11 *default-log-port* "Initialized test database " dbpath)
(tdb:testdb-initialize db)))
;; (sqlite3:execute db "PRAGMA synchronous = 0;")
(debug:print-info 11 *default-log-port* "open-test-db END (sucessful)" work-area)
;; now let's test that everything is correct
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
(debug:print-error 0 *default-log-port* "problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file "
dbpath ".\n "
((condition-property-accessor 'exn 'message) exn))
#f)
;; Is there a cheaper single line operation that will check for existance of a table
;; and raise an exception ?
(sqlite3:execute db "SELECT id FROM test_data LIMIT 1;"))
db)
;; no work-area or not readable - create a placeholder to fake rest of world out
(let ((baddb (sqlite3:open-database ":memory:")))
(debug:print-info 11 *default-log-port* "open-test-db END (unsucessful)" work-area)
;; provide an in-mem db (this is dangerous!)
(tdb:testdb-initialize baddb)
baddb)))
;; find and open the testdat.db file for an existing test
(define (tdb:open-test-db-by-test-id test-id #!key (work-area #f))
|
|
|
|
|
|
|
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
|
(set! dbdat (cons (cons 'dbname ":memory:") dbdat)))))
(tdb-writeable (and (file-write-access? work-area)
(file-write-access? dbpath)))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000))))
;;(if (and tdb-writeable
;; *db-write-access*)
;; (sqlite3:set-busy-handler! db handler))
(if (not dbexists)
(begin
(db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
(debug:print-info 11 *default-log-port* "Initialized test database " dbpath)
(tdb:testdb-initialize db)))
;; (sqlite3:execute db "PRAGMA synchronous = 0;")
(debug:print-info 11 *default-log-port* "open-test-db END (sucessful)" work-area)
;; now let's test that everything is correct
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
(debug:print-error 0 *default-log-port* "problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file "
dbpath ".\n "
((condition-property-accessor 'exn 'message) exn))
#f)
;; Is there a cheaper single line operation that will check for existance of a table
;; and raise an exception ?
(dbi:exec db "SELECT id FROM test_data LIMIT 1;"))
db)
;; no work-area or not readable - create a placeholder to fake rest of world out
(let ((baddb (dbi:open 'sqlite3 '((dbname . ":memory:")))))
(debug:print-info 11 *default-log-port* "open-test-db END (unsucessful)" work-area)
;; provide an in-mem db (this is dangerous!)
(tdb:testdb-initialize baddb)
baddb)))
;; find and open the testdat.db file for an existing test
(define (tdb:open-test-db-by-test-id test-id #!key (work-area #f))
|
| ︙ | | | ︙ | |
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
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 *default-log-port* "db:testdb-initialize START")
(sqlite3:with-transaction
db
(lambda ()
(for-each
(lambda (sqlcmd)
(sqlite3:execute db sqlcmd))
(list "CREATE TABLE IF NOT EXISTS test_rundat (
id INTEGER PRIMARY KEY,
update_time TIMESTAMP,
cpuload INTEGER DEFAULT -1,
diskfree INTEGER DEFAULT -1,
diskusage INTGER DEFAULT -1,
run_duration INTEGER DEFAULT 0);"
|
|
|
|
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
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 *default-log-port* "db:testdb-initialize START")
(dbi:with-transaction
db
(lambda ()
(for-each
(lambda (sqlcmd)
(dbi:exec db sqlcmd))
(list "CREATE TABLE IF NOT EXISTS test_rundat (
id INTEGER PRIMARY KEY,
update_time TIMESTAMP,
cpuload INTEGER DEFAULT -1,
diskfree INTEGER DEFAULT -1,
diskusage INTGER DEFAULT -1,
run_duration INTEGER DEFAULT 0);"
|
| ︙ | | | ︙ | |
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
|
CONSTRAINT metadat_constraint UNIQUE (var));"))))
(debug:print 11 *default-log-port* "db:testdb-initialize END"))
;; This routine moved to db:read-test-data
;;
(define (tdb:read-test-data tdb test-id categorypatt)
(let ((res '()))
(sqlite3:for-each-row
(lambda (id test_id category variable value expected tol units comment status type)
(set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
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)))
;;======================================================================
;; T E S T D A T A
;;======================================================================
;; ;; get a list of test_data records matching categorypatt
|
|
|
|
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
CONSTRAINT metadat_constraint UNIQUE (var));"))))
(debug:print 11 *default-log-port* "db:testdb-initialize END"))
;; This routine moved to db:read-test-data
;;
(define (tdb:read-test-data tdb test-id categorypatt)
(let ((res '()))
(dbi:for-each-row
(lambda (id test_id category variable value expected tol units comment status type)
(set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
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)
(dbi:close tdb)
(reverse res)))
;;======================================================================
;; T E S T D A T A
;;======================================================================
;; ;; get a list of test_data records matching categorypatt
|
| ︙ | | | ︙ | |
395
396
397
398
399
400
401
402
403
404
405
406
407
408
|
(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 *default-log-port* "Can't update testdat.db for test " test-id " read-only or non-existant"))))
|
|
|
|
|
396
397
398
399
400
401
402
403
404
405
406
407
408
409
|
(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 (dbi:database? tdb)
(begin
(dbi:exec tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
cpuload diskfree minutes)
(dbi:close tdb))
(debug:print 2 *default-log-port* "Can't update testdat.db for test " test-id " read-only or non-existant"))))
|