Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -24,24 +24,29 @@ ;; TESTS ;; json doesn't do vectors, convert to list ((get-test-info-by-id) (let ((res (apply db:get-test-info-by-id db params))) (if (vector? res)(vector->list res) res))) ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params)) - ((testmeta-get-record) (vector->list (apply db:testmeta-get-record db params))) ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id db params)) ((get-count-tests-running) (db:get-count-tests-running db)) ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup db params)) - ((delete-test-records) (apply db:delete-test-records params)) + ((delete-test-records) (apply db:delete-test-records db params)) ((delete-old-deleted-test-records) (db:delete-old-deleted-test-records db)) - ((test-set-status-state) (apply db:test-set-status-state params)) - ((get-previous-test-run-record) (apply db:get-previous-test-run-record params)) + ((test-set-status-state) (apply db:test-set-status-state db params)) + ((get-previous-test-run-record) (apply db:get-previous-test-run-record db params)) ((get-matching-previous-test-run-records)(map vector->list (apply db:get-matching-previous-test-run-records db params))) ((db:test-get-logfile-info) (apply db:test-get-logfile-info db params)) ((test-get-records-for-index-file (apply db:test-get-records-for-index-file db params))) ((get-testinfo-state-status) (apply db:get-testinfo-state-status db params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new params)) - ((get-prereqs-not-met) (apply db:get-prereqs-not-met params)) + ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new db params)) + ((get-prereqs-not-met) (let ((res (apply db:get-prereqs-not-met db params))) + (map (lambda (x) + (if (vector? x) + (vector->list x) + x)) + res))) + ;; RUNS ((get-run-info) (let ((res (apply db:get-run-info db params))) (list (vector-ref res 0) (vector->list (vector-ref res 1))))) @@ -58,12 +63,12 @@ (list hedr (map vector->list data)))) ((get-runs-by-patt) (let* ((res (apply db:get-runs-by-patt db params)) (hedr (vector-ref res 0)) (data (vector-ref res 1))) (list hedr (map vector->list data)))) - ((lock/unlock-run) (apply db:lock/unlock-run params)) - ((update-run-event_time) (apply db:update-run-event_time params)) + ((lock/unlock-run) (apply db:lock/unlock-run db params)) + ((update-run-event_time) (apply db:update-run-event_time db params)) ;; MISC ((login) (apply db:login db params)) ((general-call) (let ((stmtname (car params)) (realparams (cdr params))) @@ -83,12 +88,18 @@ (thread-sleep! 3) (if pid (process-signal pid signal/kill) (thread-start! th1)) '(#t "exit process started"))) - ((testmeta-add-record) (apply db:testmeta-add-record params)) - ((testmeta-update-field) (apply db:testmeta-update-field params)) + + ;; TESTMETA + ((testmeta-get-record) (let ((res (apply db:testmeta-get-record db params))) + (if (vector? res) + (vector->list res) + res))) + ((testmeta-add-record) (apply db:testmeta-add-record db params)) + ((testmeta-update-field) (apply db:testmeta-update-field db params)) (else (list "ERROR" 0)))) ;; http-server send-response ;; api:process-request Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1052,15 +1052,15 @@ ((rundir) " ORDER BY length(rundir) ") ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) ((event_time) " ORDER BY event_time ") (else (if (string? sort-by) - (conc " ORDER BY " sort-by) + (conc " ORDER BY " sort-by " ") " "))) (if sort-order sort-order " ") - (if limit (conc " LIMIT " limit) "") - (if offset (conc " OFFSET " offset) "") + (if limit (conc " LIMIT " limit) " ") + (if offset (conc " OFFSET " offset) " ") ";" ))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) @@ -1086,19 +1086,21 @@ (vector-ref inrec 3) ;; item-path -1 "-" "-")) (define (db:get-tests-for-run-state-status db run-id testpatt) - (let ((res '()) - (tests-match-qry (tests:match->sqlqry testpatt))) + (let* ((res '()) + (tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) + (debug:print-info 8 "db:get-tests-for-run qry=" qry) (sqlite3:for-each-row (lambda (id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) db - (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")) + qry run-id) res)) (define (db:get-testinfo-state-status db test-id) (let ((res #f)) @@ -1589,17 +1591,17 @@ ;; ;; (define (cdb:set-verbosity serverdat val) ;; (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val)) ;; ;; (define (cdb:num-clients serverdat) ;; (cdb:client-call serverdat 'numclients #t *default-numtries*)) -;; -;; (define (db:test-set-status-state db test-id status state msg) -;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) -;; (db:general-call db 'set-test-start-time (list test-id))) -;; (if msg -;; (db:general-call db 'state-status-msg (list state status msg test-id)) -;; (db:general-call db 'state-status (list state status test-id)))) + +(define (db:test-set-status-state db test-id status state msg) + (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) + (db:general-call db 'set-test-start-time (list test-id))) + (if msg + (db:general-call db 'state-status-msg (list state status msg test-id)) + (db:general-call db 'state-status (list state status test-id)))) ;; ;; (define (cdb:test-rollup-test_data-pass-fail serverdat test-id) ;; (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id)) ;; ;; (define (cdb:tests-register-test serverdat run-id test-name item-path) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -159,17 +159,17 @@ ;; speed up for common cases with a little logic (define (mt:test-set-state-status-by-id test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) - (cdb:client-call *runremote* 'state-status-msg #t *default-numtries* newstate newstatus newcomment test-id)) + (rmt:general-call 'state-status-msg newstate newstatus newcomment test-id)) ((and newstate newstatus) - (cdb:client-call *runremote* 'state-status #t *default-numtries* newstate newstatus test-id)) + (rmt:general-call 'state-status newstate newstatus test-id)) (else - (if newstate (cdb:client-call *runremote* 'set-test-state #t *default-numtries* newstate test-id)) - (if newstatus (cdb:client-call *runremote* 'set-test-status #t *default-numtries* newstatus test-id)) - (if newcomment (cdb:client-call *runremote* 'set-test-comment #t *default-numtries* newcomment test-id)))) + (if newstate (rmt:general-call 'set-test-state newstate test-id)) + (if newstatus (rmt:general-call 'set-test-status newstatus test-id)) + (if newcomment (rmt:general-call 'set-test-comment newcomment test-id)))) (mt:process-triggers test-id newstate newstatus) #t) (define (mt:lazy-get-test-info-by-id test-id) (let* ((tdat (hash-table-ref/default *test-info* test-id #f))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -150,11 +150,16 @@ (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) (rmt:send-receive 'test-get-paths-matching-keynames-target-new (list keynames target res testpatt statepatt statuspatt runname))) (define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) - (rmt:send-receive 'get-prereqs-not-met (list run-id waitons ref-item-path mode))) + (let ((res (rmt:send-receive 'get-prereqs-not-met (list run-id waitons ref-item-path mode)))) + (map (lambda (x) + (if (list? x) + (list->vector x) + x)) + res))) ;; Statistical queries (define (rmt:get-count-tests-running) (rmt:send-receive 'get-count-tests-running '())) @@ -246,10 +251,12 @@ (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record (list testname))) (define (rmt:testmeta-get-record testname) - (list->vector - (rmt:send-receive 'testmeta-get-record (list testname)))) + (let ((res (rmt:send-receive 'testmeta-get-record (list testname)))) + (if (list? res) + (list->vector res) + res))) (define (rmt:testmeta-update-field test-name fld val) (rmt:send-receive 'testmeta-update-field (list test-name fld val))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -383,11 +383,11 @@ (define runs:nothing-left-in-queue-count 0) (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode)) ;; (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met))) (debug:print-info 4 "START OF INNER COND #2 " "\n can-run-more: " can-run-more "\n testname: " hed @@ -588,11 +588,11 @@ (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode)) ;; (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (loop-list (list hed tal reg reruns))) (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" (string-intersperse Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -241,11 +241,11 @@ (mt:process-triggers test-id state real-status))) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) - (db:test-data-rollup #f test-id status work-area: work-area)) + (tdb:test-data-rollup #f test-id status work-area: work-area)) ;; add metadata (need to do this way to avoid SQL injection issues) ;; :first_err ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) @@ -281,17 +281,17 @@ (db:csv->test-data #f test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) - (mt:roll-up-pass-fail-counts run-id test-name item-path status)) + (rmt:roll-up-pass-fail-counts run-id test-name item-path status)) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) - (rmt:general-call 'set-test-comment (list cmt test-id)))))) + (rmt:general-call 'set-test-comment cmt test-id))))) (define (tests:test-set-toplog! run-id test-name logf) (rmt:general-call 'tests:test-set-toplog logf run-id test-name)) (define (tests:summarize-items run-id test-id test-name force) Index: tests/unittests/server.scm ================================================================== --- tests/unittests/server.scm +++ tests/unittests/server.scm @@ -78,10 +78,11 @@ (header (vector-ref runs 0)) (data (vector-ref runs 1))) (and (list? header) (list? data) (vector? (car data))))) + (inmem-test 1 1) ;;====================================================================== ;; D B