︙ | | | ︙ | |
483
484
485
486
487
488
489
490
491
492
493
494
495
496
|
(run-ids (db:get-run-ids db))) ;; iterate over runs to divy up the calls
(if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
(for-each
(lambda (run-id)
;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
;;
(sqlite3:for-each-row
(lambda (test-id)
(set! incompleted (cons test-id incompleted)))
db
"SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('RUNNING','REMOTEHOSTSTART');"
run-id deadtime)
|
>
>
>
|
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
|
(run-ids (db:get-run-ids db))) ;; iterate over runs to divy up the calls
(if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
(for-each
(lambda (run-id)
;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
;;
;; THIS CANNOT WORK. The run_duration is not updated in the central db due to performance concerns.
;; The testdat.db file must be consulted.
;;
(sqlite3:for-each-row
(lambda (test-id)
(set! incompleted (cons test-id incompleted)))
db
"SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('RUNNING','REMOTEHOSTSTART');"
run-id deadtime)
|
︙ | | | ︙ | |
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
|
res))
;; this one is a bit broken BUG FIXME
(define (db:delete-test-step-records db test-id #!key (work-area #f))
;; Breaking it into two queries for better file access interleaving
(let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
;; test db's can go away - must check every time
(if tdb
(begin
(sqlite3:execute tdb "DELETE FROM test_steps;")
(sqlite3:execute tdb "DELETE FROM test_data;")
(sqlite3:finalize! tdb)))))
;;
(define (db:delete-test-records db tdb test-id #!key (force #f))
|
|
|
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
|
res))
;; this one is a bit broken BUG FIXME
(define (db:delete-test-step-records db test-id #!key (work-area #f))
;; Breaking it into two queries for better file access interleaving
(let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
;; test db's can go away - must check every time
(if (sqlite3:database? tdb)
(begin
(sqlite3:execute tdb "DELETE FROM test_steps;")
(sqlite3:execute tdb "DELETE FROM test_data;")
(sqlite3:finalize! tdb)))))
;;
(define (db:delete-test-records db tdb test-id #!key (force #f))
|
︙ | | | ︙ | |
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
|
;;======================================================================
;; T E S T D A T A
;;======================================================================
(define (db:csv->test-data db test-id csvdata #!key (work-area #f))
(debug:print 4 "test-id " test-id ", csvdata: " csvdata)
(let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
(if tdb
(let ((csvlist (csv->list (make-csv-reader
(open-input-string csvdata)
'((strip-leading-whitespace? #t)
(strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata)))
(for-each
(lambda (csvrow)
(let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
|
|
|
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
|
;;======================================================================
;; T E S T D A T A
;;======================================================================
(define (db:csv->test-data db test-id csvdata #!key (work-area #f))
(debug:print 4 "test-id " test-id ", csvdata: " csvdata)
(let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
(if (sqlite3:database? tdb)
(let ((csvlist (csv->list (make-csv-reader
(open-input-string csvdata)
'((strip-leading-whitespace? #t)
(strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata)))
(for-each
(lambda (csvrow)
(let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
|
︙ | | | ︙ | |
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
|
test-id category variable value expected tol units (if comment comment "") status type)))
csvlist)
(sqlite3:finalize! tdb)))))
;; get a list of test_data records matching categorypatt
(define (db:read-test-data db test-id categorypatt #!key (work-area #f))
(let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
(if tdb
(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)
|
|
|
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
|
test-id category variable value expected tol units (if comment comment "") status type)))
csvlist)
(sqlite3:finalize! tdb)))))
;; get a list of test_data records matching categorypatt
(define (db:read-test-data db test-id categorypatt #!key (work-area #f))
(let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
(if (sqlite3:database? tdb)
(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)
|
︙ | | | ︙ | |
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
|
;; look at the test_data status field,
;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
(define (db:test-data-rollup db test-id status #!key (work-area #f))
(let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
(fail-count 0)
(pass-count 0))
(if tdb
(begin
(sqlite3:for-each-row
(lambda (fcount pcount)
(set! fail-count fcount)
(set! pass-count pcount))
tdb
"SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
|
|
|
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
|
;; look at the test_data status field,
;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
(define (db:test-data-rollup db test-id status #!key (work-area #f))
(let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
(fail-count 0)
(pass-count 0))
(if (sqlite3:database? tdb)
(begin
(sqlite3:for-each-row
(lambda (fcount pcount)
(set! fail-count fcount)
(set! pass-count pcount))
tdb
"SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
|
︙ | | | ︙ | |
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
|
(define (db:step-get-time-as-string vec)
(seconds->time-string (db:step-get-event_time vec)))
;; db-get-test-steps-for-run
(define (db:get-steps-for-test db test-id #!key (work-area #f))
(let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
(res '()))
(if tdb
(handle-exceptions
exn
(debug:print 0 "ERROR: error on access to testdat for test with id " test-id)
'()
(sqlite3:for-each-row
(lambda (id test-id stepname state status event-time logfile)
(set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
|
|
|
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
|
(define (db:step-get-time-as-string vec)
(seconds->time-string (db:step-get-event_time vec)))
;; db-get-test-steps-for-run
(define (db:get-steps-for-test db test-id #!key (work-area #f))
(let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
(res '()))
(if (sqlite3:database? tdb)
(handle-exceptions
exn
(debug:print 0 "ERROR: error on access to testdat for test with id " test-id)
'()
(sqlite3:for-each-row
(lambda (id test-id stepname state status event-time logfile)
(set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
|
︙ | | | ︙ | |
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
|
;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
(if (not ever-seen)
(set! result (append (if (null? tests)(list waitontest-name) tests) result)))))
waitons)
(delete-duplicates result))))
(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile #!key (work-area #f))
(debug:print 4 "test-id: " test-id " teststep-name: " teststep-name)
;; db:open-test-db-by-test-id does cdb:remote-run
(let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
(state (items:check-valid-items "state" state-in))
(status (items:check-valid-items "status" status-in)))
(if (or (not state)(not status))
(debug:print 3 "WARNING: Invalid " (if status "status" "state")
" value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
(if tdb
(begin
(sqlite3:execute
tdb
"INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))
(sqlite3:finalize! tdb)
#t)
|
<
|
|
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
|
;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
(if (not ever-seen)
(set! result (append (if (null? tests)(list waitontest-name) tests) result)))))
waitons)
(delete-duplicates result))))
(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile #!key (work-area #f))
;; db:open-test-db-by-test-id does cdb:remote-run
(let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
(state (items:check-valid-items "state" state-in))
(status (items:check-valid-items "status" status-in)))
(if (or (not state)(not status))
(debug:print 3 "WARNING: Invalid " (if status "status" "state")
" value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
(if (sqlite3:database? tdb)
(begin
(sqlite3:execute
tdb
"INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))
(sqlite3:finalize! tdb)
#t)
|
︙ | | | ︙ | |