︙ | | | ︙ | |
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.")
(exit))))
(let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname)
(dbexists (file-exists? dbpath))
(write-access (file-write-access? dbpath))
(db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000)))) ;; 136000))) ;; 136000 = 2.2 minutes
(if (and dbexists
(not write-access))
(set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
(debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv))
|
<
>
|
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.")
(exit))))
(let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname)
(dbexists (file-exists? dbpath))
(db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
(write-access (file-write-access? dbpath))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000)))) ;; 136000))) ;; 136000 = 2.2 minutes
(if (and dbexists
(not write-access))
(set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
(debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv))
|
︙ | | | ︙ | |
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
(let* ((path (configf:lookup *configdat* "setup" "tmpdb"))
(fname (if path (conc path "/temp-megatest.db") #f))
(exists (and path (file-exists? fname)))
(db (if path
(begin
(create-directory path #t)
(sqlite3:open-database fname))
(sqlite3:open-database ":memory:"))))
(if (not exists) (db:initialize db))
db))
(define (db:sync-to fromdb todb)
;; strategy
;; 1. Get all run-ids
;; 2. For each run-id
;; a. Sync that run in a transaction
|
|
>
>
>
|
>
|
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
(let* ((path (configf:lookup *configdat* "setup" "tmpdb"))
(fname (if path (conc path "/temp-megatest.db") #f))
(exists (and path (file-exists? fname)))
(db (if path
(begin
(create-directory path #t)
(sqlite3:open-database fname))
(sqlite3:open-database ":memory:")))
(handler (make-busy-timeout 3600)))
(if (or (not path)
(not exists))
(db:initialize db))
(sqlite3:set-busy-handler! db handler)
db))
(define (db:sync-to fromdb todb)
;; strategy
;; 1. Get all run-ids
;; 2. For each run-id
;; a. Sync that run in a transaction
|
︙ | | | ︙ | |
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
|
(lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
(set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
db
qry
)
res))
(define (db:delete-test-records db tdb test-id #!key (force #f))
(if tdb
(begin
(sqlite3:execute tdb "DELETE FROM test_steps;")
(sqlite3:execute tdb "DELETE FROM test_data;"))
(tdb:delete-test-step-records db test-id))
(if db
(begin
(sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id)
(sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id)
(if force
(sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)
(sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))))
(define (db:delete-tests-for-run db run-id)
(sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id))
(define (db:delete-old-deleted-test-records db)
(let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past
(sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime)))
|
|
<
<
<
<
|
<
<
<
<
<
<
|
|
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
|
(lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
(set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
db
qry
)
res))
(define (db:delete-test-records db test-id)
(tdb:delete-test-step-records db test-id)
(sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))
(define (db:delete-tests-for-run db run-id)
(sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id))
(define (db:delete-old-deleted-test-records db)
(let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past
(sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime)))
|
︙ | | | ︙ | |
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
|
;; (define (cdb:remote-run proc db . params)
;; (if (or *db-write-access*
;; (not (member proc *db:all-write-procs*)))
;; (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)
;; (begin
;; (debug:print 0 "ERROR: Attempt to access read-only database")
;; #f)))
(define (db:test-get-logfile-info db run-id test-name)
(let ((res #f))
(sqlite3:for-each-row
(lambda (path final_logf)
(set! logf final_logf)
(set! res (list path final_logf))
|
>
>
>
>
>
>
>
>
>
>
>
|
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
|
;; (define (cdb:remote-run proc db . params)
;; (if (or *db-write-access*
;; (not (member proc *db:all-write-procs*)))
;; (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)
;; (begin
;; (debug:print 0 "ERROR: Attempt to access read-only database")
;; #f)))
(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status)
(if (and (not (equal? item-path ""))
(member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))
(begin
(db:general-call 'update-pass-fail-counts db (list run-id test-name run-id test-name))
(if (equal? status "RUNNING")
(db:general-call 'top-test-set-running db (list run-id test-name))
(db:general-call 'top-test-set-per-pf-counts db (list run-id test-name run-id test-name)))
#f)
#f))
(define (db:test-get-logfile-info db run-id test-name)
(let ((res #f))
(sqlite3:for-each-row
(lambda (path final_logf)
(set! logf final_logf)
(set! res (list path final_logf))
|
︙ | | | ︙ | |
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
|
(conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
;; for each run starting with the most recent look to see if there is a matching test
;; if found then return that matching test record
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) #f
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path)'() '() #f #f #f #f #f)))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
(if (and (null? results)
(not (null? tal)))
(loop (car tal)(cdr tal))
(if (null? results) #f
(car results))))))))))
|
|
|
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
|
(conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
;; for each run starting with the most recent look to see if there is a matching test
;; if found then return that matching test record
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) #f
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
(if (and (null? results)
(not (null? tal)))
(loop (car tal)(cdr tal))
(if (null? results) #f
(car results))))))))))
|
︙ | | | ︙ | |
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
|
;; collect all matching tests for the runs then
;; extract the most recent test and return that.
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) '() ;; no previous runs? return null
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f)))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
", item-path " item-path " results: " (intersperse results "\n"))
;; Keep only the youngest of any test/item combination
(for-each
(lambda (testdat)
(let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
(stored-test (hash-table-ref/default tests-hash full-testname #f)))
|
|
|
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
|
;; collect all matching tests for the runs then
;; extract the most recent test and return that.
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) '() ;; no previous runs? return null
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
", item-path " item-path " results: " (intersperse results "\n"))
;; Keep only the youngest of any test/item combination
(for-each
(lambda (testdat)
(let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
(stored-test (hash-table-ref/default tests-hash full-testname #f)))
|
︙ | | | ︙ | |