Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -320,26 +320,26 @@ ((red) "223 33 49") ((grey) "192 192 192") ((orange) "255 172 13") ((purple) "This is unfinished ..."))) -(define (common:get-color-for-state-status state status) - (case (string->symbol state) - ((COMPLETED) - (case (string->symbol status) - ((PASS) "70 249 73") - ((WARN WAIVED) "255 172 13") - ((SKIP) "230 230 0") - (else "223 33 49"))) - ((LAUNCHED) "101 123 142") - ((CHECK) "255 100 50") - ((REMOTEHOSTSTART) "50 130 195") - ((RUNNING) "9 131 232") - ((KILLREQ) "39 82 206") - ((KILLED) "234 101 17") - ((NOT_STARTED) "240 240 240") - (else "192 192 192"))) +;; (define (common:get-color-for-state-status state status) +;; (case (string->symbol state) +;; ((COMPLETED) +;; (case (string->symbol status) +;; ((PASS) "70 249 73") +;; ((WARN WAIVED) "255 172 13") +;; ((SKIP) "230 230 0") +;; (else "223 33 49"))) +;; ((LAUNCHED) "101 123 142") +;; ((CHECK) "255 100 50") +;; ((REMOTEHOSTSTART) "50 130 195") +;; ((RUNNING) "9 131 232") +;; ((KILLREQ) "39 82 206") +;; ((KILLED) "234 101 17") +;; ((NOT_STARTED) "240 240 240") +;; (else "192 192 192"))) (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -374,11 +374,11 @@ (teststate (db:test-get-state test)) (teststart (db:test-get-event_time test)) (runtime (db:test-get-run_duration test)) (buttontxt (if (equal? teststate "COMPLETED") teststatus teststate)) (button (vector-ref columndat rown)) - (color (common:get-color-for-state-status teststate teststatus)) + (color (car (gutils:get-color-for-state-status teststate teststatus))) (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) (if (not (equal? curr-color color)) (iup:attribute-set! button "BGCOLOR" color)) (if (not (equal? curr-title buttontxt)) @@ -654,30 +654,35 @@ ;; (define (tests window-id) (define (dashboard:one-run) (let* ((tb (iup:treebox #:value 0 #:name "Runs" + #:expand "YES" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id (cdr run-path)))) (if run-id - (dboard:data-set-curr-run-id *data*)) + (begin + (dboard:data-set-curr-run-id! *data* run-id) + (dashboard:update-run-summary-tab))) (print "path: " (tree:node->path obj id) " run-id: " run-id))))) (run-matrix (iup:matrix #:expand "YES")) (updater (lambda () (let* ((runs-dat (mt:get-runs-by-patt *keys* "%" #f)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:data-get-curr-run-id *data*)) - (tests-dat (mt:get-tests-for-run run-id "%" '() '() - qryval: "id,testname,item_path,state,status")) ;; get 'em all + (tests-dat (let ((tdat (mt:get-tests-for-run run-id "%" '() '() + qryvals: "id,testname,item_path,state,status"))) ;; get 'em all + (sort tdat (lambda (a b) + (string<= (vector-ref a 2)(vector-ref b 2)))))) (tests-mindat (dcommon:minimize-test-data tests-dat)) (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) - (row-indices (car indices)) - (col-indices (cadr indices)) + (row-indices (cadr indices)) + (col-indices (car indices)) (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (apply max (map cadr col-indices)))) (max-visible (max (- *num-tests* 15) 3)) ;; *num-tests* is proportional to the size of the window (numrows 1) (numcols 1) @@ -691,11 +696,11 @@ (lambda (a b) (let* ((record-a (hash-table-ref runs-hash a)) (record-b (hash-table-ref runs-hash b)) (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (> time-a time-b)))))) + (< time-a time-b)))))) ;; (iup:attribute-set! tb "VALUE" "0") ;; (iup:attribute-set! tb "NAME" "Runs") ;; Update the runs tree (for-each (lambda (run-id) @@ -710,10 +715,13 @@ ;; (conc rownum ":" colnum) col-name) ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) ;; Here we update the tests treebox and tree keys (tree:add-node tb "Runs" (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) + (let ((path ;;(string-intersperse "/" + (append key-vals (list run-name)))) + (hash-table-set! (dboard:data-get-path-run-ids *data*) path run-id)) ;; (set! colnum (+ colnum 1)) )) run-ids) (iup:attribute-set! run-matrix "CLEARVALUE" "CONTENTS") (iup:attribute-set! run-matrix "NUMCOL" max-col ) @@ -743,25 +751,28 @@ (iup:attribute-set! run-matrix key name))))) col-indices) ;; Cell contents (for-each (lambda (entry) - (let* ((row-name (car entry)) - (col-name (cadr entry)) + (debug:print-info 0 "entry=" entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) (valuedat (caddr entry)) (test-id (list-ref valuedat 0)) - (test-name (list-ref valuedat 1)) - (item-path (list-ref valuedat 2)) - (state (list-ref valuedat 3)) - (status (list-ref valuedat 4)) + (test-name row-name) ;; (list-ref valuedat 1)) + (item-path col-name) ;; (list-ref valuedat 2)) + (state (list-ref valuedat 1)) + (status (list-ref valuedat 2)) + (value (gutils:get-color-for-state-status state status)) (row-num (cadr (assoc row-name row-indices))) (col-num (cadr (assoc col-name col-indices))) (key (conc row-num ":" col-num))) - (if (not (equal? (iup:attribute run-matrix key) value)) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) (begin (set! changed #t) - (iup:attribute-set! run-matrix key value))))) + (iup:attribute-set! run-matrix key (cadr value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) tests-mindat) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) (set! dashboard:update-run-summary-tab updater) (dboard:data-set-runs-tree! *data* tb) (iup:hbox Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -725,11 +725,11 @@ (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) (begin (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) (exit 6))))) keyvals) - (set! qry-str (conc "SELECT " keystr " FROM runs WHERE runname " runwildtype " ? " key-patt " ORDER BY event_time;")) + (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time;")) (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) db @@ -849,14 +849,15 @@ ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match (define (db:get-tests-for-run db run-id testpatt states statuses offset limit not-in sort-by #!key - (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") + (qryvals #f) ) (debug:print-info 11 "db:get-tests-for-run START run-id=" run-id ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) - (let* ((res '()) + (let* ((qryvals (if qryvals qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) + (res '()) ;; if states or statuses are null then assume match all when not-in is false (states-qry (if (null? states) #f (conc " state " (if not-in Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -212,11 +212,11 @@ (if (string=? state "COMPLETED") status state)) (iup:attribute-set! (dboard:data-get-runs-matrix *data*) (conc "BGCOLOR" rownum ":" colnum) - (gutils:get-color-for-state-status state status)) + (car (gutils:get-color-for-state-status state status))) )) tests))) run-ids) (let ((updater (hash-table-ref/default (dboard:data-get-updaters *data*) window-id #f))) Index: gutils.scm ================================================================== --- gutils.scm +++ gutils.scm @@ -20,23 +20,24 @@ (let* ((c1 (map string->number (string-split color1))) (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) - (case (string->symbol state) - ((COMPLETED) - (if (equal? status "PASS") - "70 249 73" - (if (or (equal? status "WARN") - (equal? status "WAIVED")) - "255 172 13" - "223 33 49"))) ;; greenish orangeish redish - ((LAUNCHED) "101 123 142") - ((CHECK) "255 100 50") - ((REMOTEHOSTSTART) "50 130 195") - ((RUNNING) "9 131 232") - ((KILLREQ) "39 82 206") - ((KILLED) "234 101 17") - ((NOT_STARTED) "240 240 240") - (else "192 192 192"))) +(define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) + ;; ((if get-label cadr car) + (case (string->symbol state) + ((COMPLETED) + (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: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -45,21 +45,21 @@ ;;====================================================================== ;; T E S T S ;;====================================================================== -(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by #f)) - (let loop ((testsdat (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status 0 500 not-in sort-by)) +(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by #f) (qryvals #f)) + (let loop ((testsdat (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status 0 500 not-in sort-by qryvals: qryvals)) (res '()) (offset 0) (limit 500)) (let* ((full-list (append res testsdat)) (have-more (eq? (length testsdat) limit))) (if have-more (let ((new-offset (+ offset limit))) (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.") - (loop (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status new-offset limit not-in sort-by) + (loop (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status new-offset limit not-in sort-by qryvals: qryvals) full-list new-offset limit)) full-list))))