︙ | | |
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
|
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
|
-
+
-
+
|
(newstate #f)
(wtxtbox #f))
(iup:frame
#:title "Set fields"
(iup:vbox
(iup:hbox (iup:label "Comment:")
(let ((txtbox (iup:textbox #:action (lambda (val a b)
(rmt:test-set-state-status-by-id run-id test-id #f #f b)
(rmt:test-set-state-status-by-id run-id test-id #f #f b)
;; IDEA: Just set a variable with the proc to call?
(open-run-close db:test-set-state-status-by-id db test-id #f #f b)
(rmt:test-set-state-status-by-id run-id test-id #f #f b)
(set! newcomment b))
#:value (db:test-get-comment testdat)
#:expand "HORIZONTAL")))
(set! wtxtbox txtbox)
txtbox))
(apply iup:hbox
|
︙ | | |
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
|
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
|
-
+
|
(if wtxtbox
(begin
(iup:attribute-set! wtxtbox "VALUE" c)
(if (not *dashboard-comment-share-slot*)
(set! *dashboard-comment-share-slot* wtxtbox)))
))))
(begin
(open-run-close db:test-set-state-status-by-id db test-id #f status #f)
(rmt:test-set-state-status-by-id run-id test-id #f status #f)
(db:test-set-status! testdat status))))))))
btn))
(map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
(vector-set! *state-status* 1
(lambda (status color)
(for-each
(lambda (btn)
|
︙ | | |
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
|
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
|
-
+
|
#:expand "HORIZONTAL"
#:action (lambda (obj)
(let ((comment (iup:attribute comnt "VALUE"))
(test-id (db:test-get-id testdat)))
(if (or (not wpatt)
(string-match wregx comment))
(begin
(open-run-close db:test-set-state-status-by-id #f test-id #f "WAIVED" comment)
(rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment)
(db:test-set-status! testdat "WAIVED")
(cmtcmd comment)
(iup:destroy! dlog))))))
(iup:button "Cancel"
#:expand "HORIZONTAL"
#:action (lambda (obj)
(iup:destroy! dlog)))))))
|
︙ | | |
︙ | | |
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
-
-
-
+
+
+
|
;; 'read read data
;;
(define (db:done-with dbstruct run-id mod-read)
(if (not (sqlite3:database? dbstruct))
(begin
(mutex-lock! *rundb-mutex*)
(if (eq? mod-read 'mod)
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'mtime (current-milliseconds))
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'rtime (current-milliseconds)))
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'inuse #f)
(dbr:dbstruct-set-mtime! dbstruct (current-milliseconds))
(dbr:dbstruct-set-rtime! dbstruct (current-milliseconds)))
(dbr:dbstruct-set-inuse! dbstruct #f)
(mutex-unlock! *rundb-mutex*))))
;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
(let* ((db (db:get-db dbstruct run-id)))
|
︙ | | |
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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
-
+
-
+
-
-
+
+
-
+
-
+
-
+
|
;; (define (db:get-path dbstruct id)
;; (let ((fdb (db:get-filedb dbstruct)))
;; (filedb:get-path db id)))
;; 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-runvec-val dbstruct run-id 'inmem))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
(let ((rdb (dbr:dbstruct-get-inmem dbstruct))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
(if rdb
rdb
(let* ((local (dbr:dbstruct-get-local dbstruct))
(toppath (dbr:dbstruct-get-path dbstruct))
(toppath (dbr:dbstruct-get-path dbstruct))
(dbpath (conc toppath "/db/" run-id ".db"))
(dbexists (file-exists? dbpath))
(inmem (if local #f (db:open-inmem-db)))
(refdb (if local #f (db: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
(if (not dbexists)
(begin
(db:initialize-run-id-db db)
;; (sdb:initialize db)
)) ;; add strings db to rundb, not in use yet
(sqlite3:set-busy-handler! db handler)
(sqlite3:execute db "PRAGMA synchronous = 1;"))) ;; was 0 but 0 is a gamble
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'rundb db)
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'inuse #t)
(dbr:dbstruct-set-rundb! dbstruct db)
(dbr:dbstruct-set-inuse! dbstruct #t)
(if local
(begin
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'inmem db) ;; direct access ...
(dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ...
db)
(begin
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'inmem inmem)
(dbr:dbstruct-set-inmem! dbstruct inmem)
(db:sync-tables db:sync-tests-only db inmem)
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'refdb refdb)
(dbr:dbstruct-set-refdb! dbstruct refdb)
(db:sync-tables db:sync-tests-only db refdb)
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)))
|
︙ | | |
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
|
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
|
+
-
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
+
+
+
+
-
-
-
-
|
(if (not dbexists)
(begin
(db:initialize-main-db db)
(db:initialize-run-id-db db)))
db))
;; sync all touched runs to disk
;;
(define (db:sync-touched dbstruct #!key (force-sync #f))
(let ((tot-synced 0))
(for-each
(lambda (runvec)
(let ((mtime (vector-ref runvec (dbr:dbstruct-field-name->num 'mtime)))
(stime (vector-ref runvec (dbr:dbstruct-field-name->num 'stime)))
(rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb)))
(inmem (vector-ref runvec (dbr:dbstruct-field-name->num 'inmem))))
(inmem (vector-ref runvec (dbr:dbstruct-field-name->num 'inmem)))
(refdb (vector-ref runvec (dbr:dbstruct-field-name->num 'refdb))))
(if (or (> mtime stime) force-sync)
(let ((num-synced (db:sync-tables db:sync-tests-only inmem rundb)))
(let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb)))
(set! tot-synced (+ tot-synced num-synced))
(vector-set! runvec (dbr:dbstruct-field-name->num 'stime) (current-milliseconds))))))
(hash-table-values (vector-ref dbstruct 1)))
tot-synced))
;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct #!key (force-sync #f))
(let ((mtime (dbr:dbstruct-get-mtime dbstruct))
(stime (dbr:dbstruct-get-stime dbstruct))
(rundb (dbr:dbstruct-get-rundb dbstruct))
(inmem (dbr:dbstruct-get-inmem dbstruct))
(refdb (dbr:dbstruct-get-refdb dbstruct)))
(if (or (not (number? mtime))
(not (number? stime))
(> mtime stime)
force-sync)
(let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb)))
(dbr:dbstruct-set-stime! dbstruct (current-milliseconds))
num-synced)
0)))
;; close all opened run-id dbs
(define (db:close-all dbstruct)
;; finalize main.db
(db:sync-touched dbstruct force-sync: #t)
(sqlite3:finalize! (db:get-db dbstruct #f))
(for-each
(lambda (runvec)
(let ((rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb))))
(if (sqlite3:database? rundb)
(sqlite3:finalize! rundb)
(debug:print 0 "WARNING: attempting to close databases but got " rundb " instead of a database"))))
(let ((rundb (dbr:dbstruct-get-rundb dbstruct)))
(if (sqlite3:database? rundb)
(sqlite3:finalize! rundb)
(debug:print 0 "WARNING: attempting to close databases but got " rundb " instead of a database"))))
(hash-table-values (vector-ref dbstruct 1)))
;; (sdb:qry 'finalize! #f)
)
;; (filedb:finalize-db! *fdb*))
(define (db:open-inmem-db)
(let* ((db (sqlite3:open-database ":memory:"))
(handler (make-busy-timeout 3600)))
(db:initialize-run-id-db db)
;; (sdb:initialize db) ;; for future use
(sqlite3:set-busy-handler! db handler)
|
︙ | | |
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
|
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
|
-
+
|
'("iterated" #f)
'("avg_runtime" #f)
'("avg_disk" #f)
'("tags" #f)
'("jobgroup" #f)))))
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
(define (db:sync-tables tbls fromdb todb)
(define (db:sync-tables tbls fromdb todb . slave-dbs)
(cond
((not fromdb) (debug:print 0 "ERROR: db:sync-tables called with fromdb missing") -1)
((not todb) (debug:print 0 "ERROR: db:sync-tables called with todb missing") -2)
((not (sqlite3:database? fromdb))
(debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3)
((not (sqlite3:database? todb))
(debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4)
|
︙ | | |
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
|
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
410
411
412
413
414
415
416
417
418
|
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(sqlite3:for-each-row
(lambda (a . b)
(hash-table-set! todat a (apply vector a b)))
todb
full-sel)
;; first pass implementation, just insert all changed rows
(for-each
(lambda (targdb)
(let ((stmth (sqlite3:prepare todb full-ins)))
(sqlite3:with-transaction
todb
(lambda ()
(for-each ;;
(lambda (fromrow)
(let* ((a (vector-ref fromrow 0))
(curr (hash-table-ref/default todat a #f))
(same #t))
(let loop ((i 0))
(if (or (not curr)
(not (equal? (vector-ref fromrow i)(vector-ref curr i))))
(set! same #f))
(if (and same
(< i (- num-fields 1)))
(loop (+ i 1))))
(if (not same)
(begin
(apply sqlite3:execute stmth (vector->list fromrow))
(hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
fromdat)))
(sqlite3:finalize! stmth))))
(let ((stmth (sqlite3:prepare targdb full-ins)))
(sqlite3:with-transaction
targdb
(lambda ()
(for-each ;;
(lambda (fromrow)
(let* ((a (vector-ref fromrow 0))
(curr (hash-table-ref/default todat a #f))
(same #t))
(let loop ((i 0))
(if (or (not curr)
(not (equal? (vector-ref fromrow i)(vector-ref curr i))))
(set! same #f))
(if (and same
(< i (- num-fields 1)))
(loop (+ i 1))))
(if (not same)
(begin
(apply sqlite3:execute stmth (vector->list fromrow))
(hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
fromdat)))
(sqlite3:finalize! stmth)))
(append (list todb) slave-dbs))))
tbls)
(let ((runtime (- (current-milliseconds) start-time)))
(debug:print 0 "INFO: db sync, total run time " runtime " ms")
(for-each
(lambda (dat)
(let ((tblname (car dat))
(count (cdr dat)))
|
︙ | | |
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
|
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
|
-
+
|
((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 ;; (sdb:qry 'getid newcomment)
test-id))))
(mt:process-triggers test-id newstate newstatus)))
(mt:process-triggers run-id 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))
;; NEW BEHAVIOR: Count tests running in only one run!
|
︙ | | |
1
2
3
4
5
6
7
8
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
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
1
2
3
4
5
6
7
8
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
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
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
110
111
112
|
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;; dbstruct
;;======================================================================
;;
;; -path-|-megatest.db
;; |-db-|-main.db
;; |-monitor.db
;; |-sdb.db
;; |-fdb.db
;; |-1.db
;; |-<N>.db
;;
(define (make-dbr:dbstruct #!key (path #f)(local #f))
(vector
#f ;; the main db (contains runs, test_meta etc.) NOT CACHED IN MEM
(make-hash-table) ;; run-id => [ rundb inmemdb last-mod last-read last-sync refdb ]
#f ;; the global string db (use for state, status etc.)
path ;; path to database files/megatest area
local)) ;; read-only local access
;;
;; Accessors for a dbstruct
;;
(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0))
(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1))
(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2))
(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3))
(define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4))
(define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5))
(define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6))
(define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7))
(define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8))
(define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9))
(define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10))
(define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val))
(define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val))
(define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val))
(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 3 val))
(define-inline (dbr:dbstruct-set-rundb! vec val)(vector-set! vec 4 val))
(define-inline (dbr:dbstruct-set-inmem! vec val)(vector-set! vec 5 val))
(define-inline (dbr:dbstruct-set-mtime! vec val)(vector-set! vec 6 val))
(define-inline (dbr:dbstruct-set-rtime! vec val)(vector-set! vec 7 val))
(define-inline (dbr:dbstruct-set-stime! vec val)(vector-set! vec 8 val))
(define-inline (dbr:dbstruct-set-inuse! vec val)(vector-set! vec 9 val))
(define-inline (dbr:dbstruct-set-refdb! vec val)(vector-set! vec 10 val))
;; constructor for dbstruct
;;
(define (make-dbr:dbstruct #!key (path #f)(local #f))
(let ((v (make-vector 11 #f)))
(dbr:dbstruct-set-path! v path)
(dbr:dbstruct-set-local! v local)
v))
;; get and set main db
(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0))
(define-inline (dbr:dbstruct-set-main! vec db)(vector-set! vec 0 db))
;; get the runs hash
(define-inline (dbr:dbstruct-get-dbhash vec) (vector-ref vec 1))
;; the string db
(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 2))
(define-inline (dbr:dbstruct-set-strdb! vec db)(vector-set! vec 2 db))
;; path
(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 3))
(define-inline (dbr:dbstruct-set-path! vec path)(vector-set! vec 3))
;; local
(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 4))
(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 4 val))
;; get a rundb vector, create it if not already existing
(define (dbr:dbstruct-get-rundb-rec vec run-id)
(let* ((dbhash (dbr:dbstruct-get-dbhash vec)) ;; get the runs hash
(runvec (hash-table-ref/default dbhash run-id #f))) ;; get the vector for run-id
(if (vector? runvec)
runvec ;; rundb inmemdb last-mod last-read last-sync in-use refdb
(let ((nvec (vector #f #f -1 -1 -1 #f #f)))
(hash-table-set! dbhash run-id nvec)
nvec))))
;; [ rundb inmemdb last-mod last-read last-sync ]
(define-inline (dbr:dbstruct-field-name->num field-name)
(case field-name
((rundb) 0) ;; the on-disk db
((inmem) 1) ;; the in-memory db
((mtime) 2) ;; last modification time
((rtime) 3) ;; last read time
((stime) 4) ;; last sync time
((inuse) 5) ;; is the db currently in use, #t yes, #f no.
((refdb) 6) ;; the db used for reference (can be on disk or inmem)
(else -1)))
;; get/set rundb fields
(define (dbr:dbstruct-get-runvec-val vec run-id field-name)
(let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))
(fieldnum (dbr:dbstruct-field-name->num field-name)))
;; (vector-set! runvec (dbr:dbstruct-field-name->num 'inuse) #t)
(vector-ref runvec fieldnum)))
(define (dbr:dbstruct-set-runvec-val! vec run-id field-name val)
(let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
(vector-set! runvec (dbr:dbstruct-field-name->num field-name) val)))
;; get/set inmemdb
(define (dbr:dbstruct-get-inmemdb vec run-id)
(let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
(vector-ref runvec 1)))
(define (dbr:dbstruct-set-inmemdb! vec run-id inmemdb)
(let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
(vector-set! runvec 1 inmemdb)))
;; ;; get and set main db
;; (define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0))
;; (define-inline (dbr:dbstruct-set-main! vec db)(vector-set! vec 0 db))
;; ;; get the runs hash
;; (define-inline (dbr:dbstruct-get-dbhash vec) (vector-ref vec 1))
;; ;; the string db
;; (define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 2))
;; (define-inline (dbr:dbstruct-set-strdb! vec db)(vector-set! vec 2 db))
;; ;; path
;; (define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 3))
;; (define-inline (dbr:dbstruct-set-path! vec path)(vector-set! vec 3))
;; ;; local
;; (define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 4))
;; (define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 4 val))
;;
;; ;; get a rundb vector, create it if not already existing
;; (define (dbr:dbstruct-get-rundb-rec vec run-id)
;; (let* ((dbhash (dbr:dbstruct-get-dbhash vec)) ;; get the runs hash
;; (runvec (hash-table-ref/default dbhash run-id #f))) ;; get the vector for run-id
;; (if (vector? runvec)
;; runvec ;; rundb inmemdb last-mod last-read last-sync in-use refdb
;; (let ((nvec (vector #f #f -1 -1 -1 #f #f)))
;; (hash-table-set! dbhash run-id nvec)
;; nvec))))
;;
;; ;; [ rundb inmemdb last-mod last-read last-sync ]
;; (define-inline (dbr:dbstruct-field-name->num field-name)
;; (case field-name
;; ((rundb) 0) ;; the on-disk db
;; ((inmem) 1) ;; the in-memory db
;; ((mtime) 2) ;; last modification time
;; ((rtime) 3) ;; last read time
;; ((stime) 4) ;; last sync time
;; ((inuse) 5) ;; is the db currently in use, #t yes, #f no.
;; ((refdb) 6) ;; the db used for reference (can be on disk or inmem)
;; (else -1)))
;;
;; ;; get/set rundb fields
;; (define (dbr:dbstruct-get-runvec-val vec run-id field-name)
;; (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))
;; (fieldnum (dbr:dbstruct-field-name->num field-name)))
;; ;; (vector-set! runvec (dbr:dbstruct-field-name->num 'inuse) #t)
;; (vector-ref runvec fieldnum)))
;;
;; (define (dbr:dbstruct-set-runvec-val! vec run-id field-name val)
;; (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
;; (vector-set! runvec (dbr:dbstruct-field-name->num field-name) val)))
;;
;; ;; get/set inmemdb
;; (define (dbr:dbstruct-get-inmemdb vec run-id)
;; (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
;; (vector-ref runvec 1)))
;;
;; (define (dbr:dbstruct-set-inmemdb! vec run-id inmemdb)
;; (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
;; (vector-set! runvec 1 inmemdb)))
(define (make-db:test)(make-vector 20))
(define-inline (db:test-get-id vec) (vector-ref vec 0))
(define-inline (db:test-get-run_id vec) (vector-ref vec 1))
(define-inline (db:test-get-testname vec) (vector-ref vec 2))
(define-inline (db:test-get-state vec) (vector-ref vec 3))
|
︙ | | |
︙ | | |
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
-
+
|
(if (< portnum 9000)
(begin
(debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port")
(thread-sleep! 0.1)
(http-transport:try-start-server ipaddrstr (+ portnum 1) server-id))
(print "ERROR: Tried and tried but could not start the server")))
;; any error in following steps will result in a retry
(set! *runremote* (list ipaddrstr portnum))
(set! *server-info* (list ipaddrstr portnum))
(open-run-close tasks:server-set-interface-port
tasks:open-db
server-id
ipaddrstr portnum)
(debug:print 1 "INFO: Trying to start server on " ipaddrstr ":" portnum)
;; This starts the spiffy server
;; NEED WAY TO SET IP TO #f TO BIND ALL
|
︙ | | |
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
|
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
|
-
+
|
;; server last used then start shutdown
;; This thread waits for the server to come alive
(let* ((server-info (let loop ((start-time (current-seconds))
(changed #t)
(last-sdat "not this"))
(let ((sdat #f))
(mutex-lock! *heartbeat-mutex*)
(set! sdat *runremote*)
(set! sdat *server-info*)
(mutex-unlock! *heartbeat-mutex*)
(if (and sdat
(not changed)
(> (- (current-seconds) start-time) 2))
sdat
(begin
(sleep 4)
|
︙ | | |
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
|
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
|
-
+
|
;; (thread-sleep! 4) ;; no need to do this very often
(if (< count 1) ;; 3x3 = 9 secs aprox
(loop (+ count 1)))
;; Check that iface and port have not changed (can happen if server port collides)
(mutex-lock! *heartbeat-mutex*)
(set! sdat *runremote*)
(set! sdat *server-info*)
(mutex-unlock! *heartbeat-mutex*)
(if (or (not (equal? sdat (list iface port)))
(not server-id))
(begin
(debug:print-info 0 "interface changed, refreshing iface and port info")
(set! iface (car sdat))
|
︙ | | |