Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -134,14 +134,14 @@ ;; SERVERS ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ;; TESTS - ((test-set-state-status-by-id) (apply db:test-state-status-by-id-set! dbstruct params)) + ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) ((delete-test-records) (apply db:delete-test-records dbstruct params)) ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) - ((test-set-status-state) (apply db:test-status-state-set! dbstruct params)) + ((test-set-status-state) (apply db:test-set-status-state dbstruct params)) ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params)) ;; ((update-pass-fail-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params)) ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) @@ -188,27 +188,27 @@ ((get-keys) (db:get-keys dbstruct)) ((get-key-vals) (apply db:get-key-vals dbstruct params)) ((get-targets) (db:get-targets dbstruct)) ;; ARCHIVES - ((test-get-archive-block-info) (apply db:test-archive-block-info dbstruct params)) + ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) ;; TESTS ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) - ((test-get-rundir-from-test-id) (apply db:test-rundir-from-test-id dbstruct params)) + ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) - ((test-get-logfile-info) (apply db:test-logfile-info dbstruct params)) - ((test-get-records-for-index-file) (apply db:test-records-for-index-file dbstruct params)) + ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) + ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) - ((test-get-top-process-pid) (apply db:test-top-process-pid dbstruct params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-paths-matching-keynames-target-new dbstruct params)) + ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) + ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) ((synchash-get) (apply synchash:server-get dbstruct params)) ;; RUNS Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -216,15 +216,15 @@ (c2 (map string->number (string-split color2))) (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) (define (compare-tests test1 test2) - (let* ((test-name1 (db:test-testname test1)) - (item-path1 (db:test-item-path test1)) + (let* ((test-name1 (or (db:test-testname test1) "")) + (item-path1 (or (db:test-item-path test1) "")) (eventtime1 (db:test-event_time test1)) - (test-name2 (db:test-testname test2)) - (item-path2 (db:test-item-path test2)) + (test-name2 (or (db:test-testname test2) "")) + (item-path2 (or (db:test-item-path test2) "")) (eventtime2 (db:test-event_time test2)) (same-name (equal? test-name1 test-name2)) (test1-top (equal? item-path1 "")) (test2-top (equal? item-path2 "")) (test1-older (> eventtime1 eventtime2)) @@ -388,12 +388,12 @@ ;; (define (get-itemized-tests test-dats) (let ((tnames '())) (for-each (lambda (tdat) - (let ((tname (db:test-testname tdat)) ;; (db:test-get-testname tdat)) - (ipath (db:test-item-path tdat) ) ) ;; (db:test-get-item-path tdat))) + (let ((tname (vector-ref tdat 0)) ;; (db:test-testname tdat)) ;; (db:test-get-testname tdat)) + (ipath (vector-ref tdat 1))) ;; (db:test-item-path tdat) ) ) ;; (db:test-get-item-path tdat))) (if (not (equal? ipath "")) (if (and (list? tnames) (string? tname) (not (member tname tnames))) (set! tnames (append tnames (list tname))))))) @@ -410,12 +410,12 @@ (let* ((tnames '()) ;; list of names used to reserve order (tests (make-hash-table)) ;; hash of lists, used to build as we go (itemized (get-itemized-tests test-dats))) (for-each (lambda (testdat) - (let* ((tname (db:test-testname tdat)) ;; (db:test-get-testname tdat)) - (ipath (db:test-item-path tdat))) ;; (db:test-get-item-path tdat))) + (let* ((tname (vector-ref testdat 0)) ;; (db:test-testname tdat)) ;; (db:test-get-testname tdat)) + (ipath (vector-ref testdat 1))) ;; (db:test-item-path tdat))) ;; (db:test-get-item-path tdat))) ;; (seen (hash-table-ref/default tests tname #f))) (if (not (member tname tnames)) (if (or (and (eq? priority 'itempath) (not (equal? ipath ""))) (and (eq? priority 'testname) @@ -508,11 +508,25 @@ (if buttondat (let* ((test (let ((matching (filter (lambda (x)(equal? (test:test-get-fullname x) testname)) testsdat))) (if (null? matching) - (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") + (make-db:test id: -1 + run_id: -1 + testname: "" + state: "" + status: "" + event_time: 0 + host: "" + cpuload: "" + diskfree: 0 + uname: "" + rundir: "" + item-path: "" + run_duration: 0 + final_logf: "" + comment: "") (car matching)))) (testname (db:test-testname test)) (itempath (db:test-item-path test)) (testfullname (test:test-get-fullname test)) (teststatus (db:test-status test)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1140,11 +1140,11 @@ (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;" archive-block-id test-id)))) ;; Look up the archive block info given a block-id ;; -(define (db:test-archive-block-info dbstruct archive-block-id) +(define (db:test-get-archive-block-info dbstruct archive-block-id) (db:with-db dbstruct #f #f (lambda (db) @@ -2154,27 +2154,27 @@ ))) ;; (case qryvals ;; ((shortlist)(map db:test-short-record->norm res)) ;; ((#f) res) ;; (else res))))) - (if (eq? qryvals shortlist) + (if (eq? qryvals 'shortlist) (for-each (lambda (inrec) (db:test-short-record->norm inrec)) res)) res))) (define (db:test-short-record->norm inrec) ;; "id,run_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 - (db-test-event_time-set! inrec -1) - (db-test-host-set! inrec "") - (db-test-cpuload-set! inrec -1) - (db-test-diskfree-set! inrec -1) - (db-test-uname-set! inrec "") - (db-test-rundir-set! inrec "-") - (db-test-run_duration-set! inrec "-") - (db-test-final_logf-set! inrec "-") - (db-test-comment-set! inrec "-") + (db:test-event_time-set! inrec -1) + (db:test-host-set! inrec "") + (db:test-cpuload-set! inrec -1) + (db:test-diskfree-set! inrec -1) + (db:test-uname-set! inrec "") + (db:test-rundir-set! inrec "-") + (db:test-run_duration-set! inrec "-") + (db:test-final_logf-set! inrec "-") + (db:test-comment-set! inrec "-") ;; (vector (vector-ref inrec 0) ;; id ;; (vector-ref inrec 1) ;; run_id ;; (vector-ref inrec 2) ;; testname ;; (vector-ref inrec 4) ;; state @@ -2186,24 +2186,24 @@ ) (define (db:get-tests-for-run-state-status dbstruct run-id testpatt) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) - (qryfields '(id testname item_path state,status)) + (qryfields '(id testname item_path state status)) (qryfields-str (string-join (map ->string qryfields) "," )) (qry (conc "SELECT " qryfields-str " 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) (db:with-db dbstruct run-id #f (lambda (db) (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 - (let ((1res make-db:test)) + (let ((1res (make-db:test))) (db:test-id-set! 1res id) (db:test-testname-set! 1res testname) - (db:test-item_path-set! 1res item-path) + (db:test-item-path-set! 1res item-path) (db:test-state-set! 1res state) (db:test-status-set! 1res status) (db:test-short-record->norm 1res) (set! res (cons 1res res)))) ;;(set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) @@ -2627,11 +2627,11 @@ db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") test-name item-path) res)))) -(define (db:test-rundir-from-test-id dbstruct run-id test-id) +(define (db:test-get-rundir-from-test-id dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (db) @@ -2807,19 +2807,19 @@ keynames (string-split target "/")) " AND ")) ;; (testqry (tests:match->sqlqry testpatt)) (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) - ;; (debug:print 8 "db:test-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) + ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) (sqlite3:finalize! runsqry) row-ids)) -(define (db:test-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) +(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) (let* ((testqry (tests:match->sqlqry testpatt)) (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) (db:with-db dbstruct run-id @@ -2920,11 +2920,11 @@ ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) ;; #f) ;; ))) -(define (db:test-logfile-info dbstruct run-id test-name) +(define (db:test-get-logfile-info dbstruct run-id test-name) (db:with-db dbstruct run-id #f (lambda (db) @@ -3252,11 +3252,11 @@ (debug:print-info 0 "delaying db access due to high database load.") (thread-sleep! 12.8)))) db) "bogus result from db:delay-if-busy"))) -(define (db:test-records-for-index-file dbstruct run-id test-name) +(define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (db:with-db dbstruct run-id #f Index: gutils.scm ================================================================== --- gutils.scm +++ gutils.scm @@ -21,34 +21,42 @@ (c2 (map string->number (string-split color2))) (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) (define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) - ;; ((if get-label cadr car) - (case (string->symbol state) - ((COMPLETED) ;; ARCHIVED) - (case (string->symbol status) - ((PASS) (list "70 249 73" status)) - ((WARN WAIVED) (list "255 172 13" status)) - ((SKIP) (list "230 230 0" status)) - (else (list "253 33 49" status)))) - ((ARCHIVED) - (case (string->symbol status) - ((PASS) (list "70 170 73" status)) - ((WARN WAIVED) (list "200 130 13" status)) - ((SKIP) (list "180 180 0" status)) - (else (list "180 33 49" status)))) - ;; (if (equal? status "PASS") - ;; '("70 249 73" "PASS") - ;; (if (or (equal? status "WARN") - ;; (equal? status "WAIVED")) - ;; (list "255 172 13" status) - ;; (list "223 33 49" status)))) ;; greenish orangeish redish - ((LAUNCHED) (list "101 123 142" state)) - ((CHECK) (list "255 100 50" state)) - ((REMOTEHOSTSTART) (list "50 130 195" state)) - ((RUNNING) (list "9 131 232" state)) - ((KILLREQ) (list "39 82 206" state)) - ((KILLED) (list "234 101 17" state)) - ((NOT_STARTED) (list "240 240 240" state)) - (else (list "192 192 192" state)))) + (cond + ((not (string? state)) + (debug:print 0 "ERROR: gutils:get-color-for-state-status recieved non-string state " state) + (list "253 33 49" status)) + ((not (string? status)) + (debug:print 0 "ERROR: gutils:get-color-for-state-status recieved non-string status " status) + (list "253 33 49" status)) + (else + ;; ((if get-label cadr car) + (case (string->symbol state) + ((COMPLETED) ;; ARCHIVED) + (case (string->symbol status) + ((PASS) (list "70 249 73" status)) + ((WARN WAIVED) (list "255 172 13" status)) + ((SKIP) (list "230 230 0" status)) + (else (list "253 33 49" status)))) + ((ARCHIVED) + (case (string->symbol status) + ((PASS) (list "70 170 73" status)) + ((WARN WAIVED) (list "200 130 13" status)) + ((SKIP) (list "180 180 0" status)) + (else (list "180 33 49" status)))) + ;; (if (equal? status "PASS") + ;; '("70 249 73" "PASS") + ;; (if (or (equal? status "WARN") + ;; (equal? status "WAIVED")) + ;; (list "255 172 13" status) + ;; (list "223 33 49" status)))) ;; greenish orangeish redish + ((LAUNCHED) (list "101 123 142" state)) + ((CHECK) (list "255 100 50" state)) + ((REMOTEHOSTSTART) (list "50 130 195" state)) + ((RUNNING) (list "9 131 232" state)) + ((KILLREQ) (list "39 82 206" state)) + ((KILLED) (list "234 101 17" state)) + ((NOT_STARTED) (list "240 240 240" state)) + (else (list "192 192 192" state)))))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1012,11 +1012,11 @@ (let ((id (db:test-id trec)) (tn (db:test-testname trec)) (ip (db:test-item-path trec)) (st (db:test-state trec))) (if (not (equal? st "DELETED")) - (hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol st))))) + (hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol (or st "#F=>BAD DATA")))))) tests-info) (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) @@ -1155,15 +1155,14 @@ " ") "\n")) items))) (for-each (lambda (my-itemdat) - (let* ((new-test-record (let ((newrec (make-tests:testqueue))) - (vector-copy! test-record newrec) - newrec)) - (my-item-path (item-list->path my-itemdat))) - (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! + (let* ((new-test-record (make-tests:testqueue)) + ;; (update-tests:testqueue test-record))) + (my-item-path (item-list->path my-itemdat))) + (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! (let ((newtestname (db:test-make-full-name hed my-item-path))) ;; test names are unique on testname/item-path (tests:testqueue-set-items! new-test-record #f) (tests:testqueue-set-itemdat! new-test-record my-itemdat) (tests:testqueue-set-item_path! new-test-record my-item-path) (hash-table-set! test-records newtestname new-test-record) Index: tests/unittests/runs.scm ================================================================== --- tests/unittests/runs.scm +++ tests/unittests/runs.scm @@ -119,10 +119,14 @@ (comment (conc "This is a comment for itempath " itempath))) ;; (rmt:test-set-state-status-by-id run-id test-id "COMPLETED" "PASS" comment) (tests:test-set-status! 1 test-id "COMPLETED" "PASS" comment #f))) ;; #!key (work-area #f)) '("item/1" "item/2" "item/3" "item/4" "item/5")) + +(exit) + + (test #f #t (number? (rmt:get-test-id 1 "rollup" "item/4"))) (define (get-state-status run-id testname itempath) (let ((tdat (rmt:get-test-info-by-id 1 (rmt:get-test-id run-id testname itempath)))) (list (db:test-state tdat)