| ︙ | | | ︙ | |
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
|
;; This routine creates the db. It is only called if the db is not already opened
;;
(define (db:open-rundb dbstruct run-id) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let ((rdb (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
(if rdb
rdb
(let* ((toppath (dbr:dbstruct-get-path dbstruct))
(dbpath (conc toppath "/db/" run-id ".db"))
(dbexists (file-exists? dbpath))
(inmem (open-inmem-db))
(db (sqlite3:open-database dbpath))
(write-access (file-write-access? dbpath))
(handler (make-busy-timeout 136000)))
(if (and dbexists (not write-access))
(set! *db-write-access* #f)) ;; only unset so other db's also can use this control
(if write-access
(begin
(sqlite3:set-busy-handler! db handler)
(sqlite3:execute db "PRAGMA synchronous = 0;")))
(if (not dbexists)(db:initialize-run-id-db db run-id))
(dbr:dbstruct-set-runvec! dbstruct run-id 'rundb db)
(dbr:dbstruct-set-runvec! dbstruct run-id 'inmem inmem)
(dbr:dbstruct-set-runvec! dbstruct run-id 'inuse #t)
(db:sync-tables db:sync-tests-only db inmem)
inmem))))
;; This routine creates the db. It is only called if the db is not already opened
;;
(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let ((mdb (dbr:dbstruct-get-main dbstruct)))
(if mdb
mdb
|
>
|
|
|
>
>
>
|
|
|
|
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
|
;; This routine creates the db. It is only called if the db is not already opened
;;
(define (db:open-rundb dbstruct run-id) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let ((rdb (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
(if rdb
rdb
(let* ((local (dbr:dbstruct-get-local dbstruct))
(toppath (dbr:dbstruct-get-path dbstruct))
(dbpath (conc toppath "/db/" run-id ".db"))
(dbexists (file-exists? dbpath))
(inmem (if local #f (open-inmem-db)))
(db (sqlite3:open-database dbpath))
(write-access (file-write-access? dbpath))
(handler (make-busy-timeout 136000)))
(if (and dbexists (not write-access))
(set! *db-write-access* #f)) ;; only unset so other db's also can use this control
(if write-access
(begin
(sqlite3:set-busy-handler! db handler)
(sqlite3:execute db "PRAGMA synchronous = 0;")))
(if (not dbexists)(db:initialize-run-id-db db run-id))
(dbr:dbstruct-set-runvec! dbstruct run-id 'rundb db)
(dbr:dbstruct-set-runvec! dbstruct run-id 'inuse #t)
(if local
db
(begin
(dbr:dbstruct-set-runvec! dbstruct run-id 'inmem inmem)
(db:sync-tables db:sync-tests-only db inmem)
inmem))))))
;; This routine creates the db. It is only called if the db is not already opened
;;
(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let ((mdb (dbr:dbstruct-get-main dbstruct)))
(if mdb
mdb
|
| ︙ | | | ︙ | |
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
(if (> mtime stime)
(begin
(db:sync-tables db:sync-tests-only inmem rundb)
(vector-set! runvec (dbr:dbstruct-field-name->run 'stime (current-milliseconds)))))))
(hash-table-values (vector-ref dbstruct 1))))
;; close all opened run-id dbs
(define (db:close-all-db)
(for-each
(lambda (db)
(finalize! db))
(hash-table-values (vector-ref *open-dbs* 1)))
(finalize! (vector-ref *open-dbs* 0)))
(define (open-inmem-db)
(let* ((db (sqlite3:open-database ":memory:"))
(handler (make-busy-timeout 3600)))
(db:initialize db)
(sqlite3:set-busy-handler! db handler)
(set! sdb:qry (make-sdb:qry)) ;; we open the normalization helpers here
|
|
>
>
|
>
|
|
<
|
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
(if (> mtime stime)
(begin
(db:sync-tables db:sync-tests-only inmem rundb)
(vector-set! runvec (dbr:dbstruct-field-name->run 'stime (current-milliseconds)))))))
(hash-table-values (vector-ref dbstruct 1))))
;; close all opened run-id dbs
(define (db:close-all dbstruct)
;; finalize main.db
(sqlite3:finalize! (db:get-db dbstruct #f))
(for-each
(lambda (runvec)
(let ((rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb))))
(sqlite3:finalize! rundb)))
(hash-table-values (vector-ref dbstruct 1))))
(define (open-inmem-db)
(let* ((db (sqlite3:open-database ":memory:"))
(handler (make-busy-timeout 3600)))
(db:initialize db)
(sqlite3:set-busy-handler! db handler)
(set! sdb:qry (make-sdb:qry)) ;; we open the normalization helpers here
|
| ︙ | | | ︙ | |
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
|
(db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*))
;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling proc idb . params)
(debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
(if (or *db-write-access*
(not (member proc *db:all-write-procs*)))
(let* ((db (cond
((sqlite3:database? idb) idb)
((not idb) (make-dbr:dbstruct path: *toppath*))
((procedure? idb) (idb))
(else (make-dbr:dbstruct path: *toppath*))))
(res #f))
(set! res (apply proc db params))
(if (not idb)(sqlite3:finalize! db))
(debug:print-info 11 "open-run-close-no-exception-handling END" )
res)
#f))
(define (open-run-close-exception-handling proc idb . params)
(handle-exceptions
exn
(begin
(debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
(debug:print 0 " " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain)
(thread-sleep! (random 120))
(debug:print-info 0 "trying db call one more time....")
(apply open-run-close-no-exception-handling proc idb params))
(apply open-run-close-no-exception-handling proc idb params)))
;; (define open-run-close
(define open-run-close (if (debug:debug-mode 2)
open-run-close-no-exception-handling
open-run-close-exception-handling))
(define (db:initialize-megatest-db db)
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
(keys (keys:config-get-fields configdat))
(havekeys (> (length keys) 0))
(keystr (keys->keystr keys))
(fieldstr (keys->key/field keys)))
|
|
|
|
|
|
|
|
|
|
|
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
|
(db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*))
;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling proc idb . params)
(debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
(if (or *db-write-access*
(not (member proc *db:all-write-procs*)))
(let* ((db (cond
((sqlite3:database? idb) idb)
((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore"))
((procedure? idb) (idb))
(else (debug:print 0 "ERROR: cannot open-run-close with #f anymore"))))
(res #f))
(set! res (apply proc db params))
(if (not idb)(sqlite3:finalize! dbstruct))
(debug:print-info 11 "open-run-close-no-exception-handling END" )
res)
#f))
(define (open-run-close-exception-handling proc idb . params)
(handle-exceptions
exn
(begin
(debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
(debug:print 0 " " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain)
(thread-sleep! (random 120))
(debug:print-info 0 "trying db call one more time....")
(apply open-run-close-no-exception-handling proc idb params))
(apply open-run-close-no-exception-handling proc idb params)))
;; (define open-run-close
(define open-run-close ;; (if (debug:debug-mode 2)
open-run-close-no-exception-handling)
;; open-run-close-exception-handling))
(define (db:initialize-megatest-db db)
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
(keys (keys:config-get-fields configdat))
(havekeys (> (length keys) 0))
(keystr (keys->keystr keys))
(fieldstr (keys->key/field keys)))
|
| ︙ | | | ︙ | |
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
|
res))
;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;; runpatts: patt1,patt2 ...
;;
(define (db:get-runs db runpatt count offset keypatts)
(let* ((res '())
(keys (db:get-keys db))
|
|
>
|
|
|
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
|
res))
;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;; runpatts: patt1,patt2 ...
;;
(define (db:get-runs dbstruct runpatt count offset keypatts)
(let* ((db (db:get-db dbstruct #f))
(res '())
(keys (db:get-keys dbstruct))
(runpattstr (db:patt->like "runname" runpatt))
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(header (append keys remfields))
(keystr (conc (keys->keystr keys) ","
(string-intersperse remfields ",")))
(qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
;; Generate: " AND x LIKE 'keypatt' ..."
|
| ︙ | | | ︙ | |