24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses mtmod))
(module dbmod
*
(import scheme)
(cond-expand
(chicken-4
(import chicken
data-structures
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
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
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
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses mtmod))
(module dbmod
(
;; for debug, can be commented out
dbmod:safely-open-db
dbmod:db-to-db-sync
db:test-get-event_time
db:test-get-item-path
db:test-get-testname
db:get-value-by-header
db:get-subdb
db:multi-db-sync
dbmod:open-dbmoddb
dbmod:run-id->dbfname
db:roll-up-rules
db:get-all-state-status-counts-for-test
db:test-set-state-status-db
db:general-call
db:cache-for-read-only
db:convert-test-itempath
db:test-data-rollup
db:keep-trying-until-true
db:get-test-info-by-id
db:with-db
db:get-test-id
db:get-test-info
dbmod:print-db-stats
db:get-keys
db:open-no-sync-db
db:add-stats
;; dbr:counts record accessors
dbr:counts->alist
db:add-var
db:archive-register-block-name
db:archive-register-disk
db:create-all-triggers
db:csv->test-data
db:dec-var
db:del-var
db:delete-old-deleted-test-records
db:delete-run
db:delete-steps-for-test!
db:delete-test-records
db:drop-all-triggers
db:get-all-run-ids
db:get-all-runids
db:get-changed-record-ids
db:get-changed-record-run-ids
db:get-changed-record-test-ids
db:get-count-tests-running
db:get-count-tests-running-for-run-id
db:get-count-tests-running-for-testname
db:get-count-tests-running-in-jobgroup
db:get-data-info-by-id
db:get-key-val-pairs
db:get-key-vals
db:get-latest-host-load
db:get-main-run-stats
db:get-matching-previous-test-run-records
db:get-not-completed-cnt
db:get-num-runs
db:get-prereqs-not-met
db:get-prev-run-ids
db:get-raw-run-stats
db:get-run-ids-matching-target
db:get-run-info
db:get-run-name-from-id
db:get-run-record-ids
db:get-run-state
db:get-run-state-status
db:get-run-stats
db:get-run-status
db:get-run-times
db:get-runs
db:get-runs-by-patt
db:get-runs-cnt-by-patt
db:get-steps-data
db:get-steps-for-test
db:get-steps-info-by-id
db:get-target
db:get-targets
db:get-test-state-status-by-id
db:get-test-times
db:get-testinfo-state-status
db:get-tests-for-run
db:get-tests-for-run-mindata
db:get-tests-for-run-state-status
db:get-tests-tags
db:get-toplevels-and-incompletes
db:get-var
db:have-incompletes?
db:inc-var
db:initialize-main-db
db:insert-run
db:insert-test
db:lock/unlock-run
db:login
db:read-test-data
db:read-test-data-varpatt
db:register-run
db:set-run-state-status
db:set-run-status
db:set-state-status-and-roll-up-run
db:set-var
db:simple-get-runs
db:test-get-archive-block-info
db:test-get-logfile-info
db:test-get-paths-matching-keynames-target-new
db:test-get-records-for-index-file
db:test-get-rundir-from-test-id
db:test-get-top-process-pid
db:test-set-archive-block-id
db:test-set-state-status
db:test-set-top-process-pid
db:test-toplevel-num-items
db:testmeta-add-record
db:testmeta-get-record
db:testmeta-update-field
db:teststep-set-status!
db:top-test-set-per-pf-counts
db:update-run-event_time
db:update-run-stats
db:update-tesdata-on-repilcate-db
tasks:add
tasks:find-task-queue-records
tasks:get-last
tasks:set-state-given-param-key
*db-stats*
dbmod:nfs-get-dbstruct
*db-stats-mutex*
db:get-header
db:get-rows
db:get-changed-run-ids
db:set-sync
db:setup
db:get-access-mode
db:test-record-fields
db:logpro-dat->csv
std-exit-procedure
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
data-structures
|
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
commonmod
configfmod
dbfile
debugprint
mtmod
)
(include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
|
|
|
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
|
commonmod
configfmod
dbfile
debugprint
mtmod
)
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
|
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
|
(begin
(db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f tmpdb mtdb)))
(hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time)))
(debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date"))))
dbfiles))
data-synced))
;; Sync all changed db's
;;
(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
(let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
(res '()))
(for-each
(lambda (subdb)
(let* ((mtdb (dbr:subdb-mtdbdat subdb))
(tmpdb (db:get-subdb dbstruct run-id))
(refndb (dbr:subdb-refndb subdb))
(newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
;; BUG: verify this is really needed
(dbfile:add-dbdat dbstruct run-id tmpdb)
(set! res (cons newres res))))
subdbs)
res))
;;;; run-ids
;; if #f use *db-local-sync* : or 'local-sync-flags
;; if #t use timestamps : or 'timestamps
;;
;; NB// no-sync-db is the db handle, not a flag!
;;
(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f))
(let* ((start-time (current-seconds))
(last-full-update (if no-sync-db
(db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0)
0))
(full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync
(last-update (if full-sync-needed
0
(if no-sync-db
(db:no-sync-get/default no-sync-db "LAST_UPDATE" 0)
0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0))
(sync-needed (> (- start-time last-update) 6))
(res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds
full-sync-needed)
(begin
(if no-sync-db
(begin
(if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time))
(db:no-sync-set no-sync-db "LAST_UPDATE" start-time)))
(db:tmp->megatest.db-sync dbstruct last-update))
0))
(sync-time (- (current-seconds) start-time)))
(debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
(if (common:low-noise-print 30 "sync new to old")
(if sync-needed
(debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
(debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
res))
(define (db:initialize-main-db db #!key (launch-setup #f))
(when (not *configinfo*)
(if launch-setup
(launch-setup) ;; added because Elena was getting stack dump because *configinfo* below was #f.
(assert #f "db:initialize-main-db called and needs launch:setup but was not given it")))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
|
(begin
(db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f tmpdb mtdb)))
(hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time)))
(debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date"))))
dbfiles))
data-synced))
;; ;; Sync all changed db's
;; ;;
;; (define (db:tmp->megatest.db-sync dbstruct run-id last-update)
;; (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
;; (res '()))
;; (for-each
;; (lambda (subdb)
;; (let* ((mtdb (dbr:subdb-mtdbdat subdb))
;; (tmpdb (db:get-subdb dbstruct run-id))
;; (refndb (dbr:subdb-refndb subdb))
;; (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
;; ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
;; ;; BUG: verify this is really needed
;; (dbfile:add-dbdat dbstruct run-id tmpdb)
;; (set! res (cons newres res))))
;; subdbs)
;; res))
;;;; run-ids
;; if #f use *db-local-sync* : or 'local-sync-flags
;; if #t use timestamps : or 'timestamps
;;
;; NB// no-sync-db is the db handle, not a flag!
;;
;; (define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f))
;; (let* ((start-time (current-seconds))
;; (last-full-update (if no-sync-db
;; (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0)
;; 0))
;; (full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync
;; (last-update (if full-sync-needed
;; 0
;; (if no-sync-db
;; (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0)
;; 0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0))
;; (sync-needed (> (- start-time last-update) 6))
;; (res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds
;; full-sync-needed)
;; (begin
;; (if no-sync-db
;; (begin
;; (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time))
;; (db:no-sync-set no-sync-db "LAST_UPDATE" start-time)))
;; (db:tmp->megatest.db-sync dbstruct run-id last-update))
;; 0))
;; (sync-time (- (current-seconds) start-time)))
;; (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
;; (if (common:low-noise-print 30 "sync new to old")
;; (if sync-needed
;; (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
;; (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
;; res))
(define (db:initialize-main-db db #!key (launch-setup #f))
(when (not *configinfo*)
(if launch-setup
(launch-setup) ;; added because Elena was getting stack dump because *configinfo* below was #f.
(assert #f "db:initialize-main-db called and needs launch:setup but was not given it")))
|
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
|
dbstruct
run-id
#t
(lambda (dbdat db)
(delproc db)))
(if (and (file-exists? mtdbfile)
(file-write-access? mtdbfile))
(let* ((db (sqlite3:open-database mtdbfile)))
(delproc db)
(sqlite3:finalize! db)))))
;; ;; 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
;;
;; NOTE: run-id is not used
|
|
>
>
|
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
|
dbstruct
run-id
#t
(lambda (dbdat db)
(delproc db)))
(if (and (file-exists? mtdbfile)
(file-write-access? mtdbfile))
(let* ((db (sqlite3:open-database mtdbfile))
(handler (sqlite3:make-busy-timeout 136000)))
(sqlite3:set-busy-handler! db handler)
(delproc db)
(sqlite3:finalize! db)))))
;; ;; 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
;;
;; NOTE: run-id is not used
|