Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -215,10 +215,11 @@ ((args:get-arg "-use-local") #f) ((configf:lookup *configdat* "dashboard" "use-server") (let ((ans (config:lookup *configdat* "dashboard" "use-server"))) (if (equal? ans "yes") #t #f))) (else #t))) +(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard"))) (d:alldat-dbdir-set! *alldat* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (d:alldat-dblocal-set! *alldat* (make-dbr:dbstruct path: (d:alldat-dbdir *alldat*) local: #t)) (d:alldat-dbfpath-set! *alldat* (db:dbfile-path 0)) @@ -349,20 +350,22 @@ sort-by sort-order 'shortlist (if (d:alldat-filters-changed data) 0 - last-update)) + last-update) + *dashboard-mode*) ;; use dashboard mode (db:get-tests-for-run (d:alldat-dblocal data) run-id testnamepatt states statuses #f #f (d:alldat-hide-not-hide data) sort-by sort-order 'shortlist (if (d:alldat-filters-changed data) 0 - last-update)))) + last-update) + *dashboard-mode*))) (tests (let ((newdat (filter (lambda (x) (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging (delete-duplicates (if (d:alldat-filters-changed data) tmptests @@ -401,18 +404,20 @@ ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names data) ;; (tests (bubble-up tmptests priority: bubble-type)) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? - (set! referenced-run-ids (cons run-id referenced-run-ids)) - (if (> (length tests) maxtests) - (set! maxtests (length tests))) - (if (or (not (d:alldat-hide-empty-runs data)) ;; this reduces the data burden when set - (not (null? tests))) - (let ((dstruct (vector run tests key-vals (- (current-seconds) 10)))) - (hash-table-set! (d:alldat-allruns-by-id data) run-id dstruct) - (set! result (cons dstruct result)))))) + (if (not (null? tests)) + (begin + (set! referenced-run-ids (cons run-id referenced-run-ids)) + (if (> (length tests) maxtests) + (set! maxtests (length tests))) + (if (or (not (d:alldat-hide-empty-runs data)) ;; this reduces the data burden when set + (not (null? tests))) + (let ((dstruct (vector run tests key-vals (- (current-seconds) 10)))) + (hash-table-set! (d:alldat-allruns-by-id data) run-id dstruct) + (set! result (cons dstruct result)))))))) runs) (d:alldat-header-set! data header) (d:alldat-allruns-set! data result) (debug:print-info 6 "(d:alldat-allruns data) has " (length (d:alldat-allruns data)) " runs") @@ -680,10 +685,11 @@ (hash-table-set! (d:alldat-searchpatts *alldat*) x val) (d:alldat-filters-changed-set! *alldat* #t) (set-bg-on-filter)) (define (mark-for-update) + (d:alldat-filters-changed-set! *alldat* #t) (d:alldat-last-db-update-set! *alldat* 0)) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== @@ -1207,11 +1213,12 @@ (d:alldat-hide-not-hide data) #f #f "id,testname,item_path,state,status" (if (d:alldat-filters-changed data) 0 - last-update)) ;; get 'em all + last-update) + *dashboard-mode*) ;; get 'em all (db:get-tests-for-run db run-id (hash-table-ref/default (d:alldat-searchpatts data) "test-name" "%/%") (hash-table-keys (d:alldat-state-ignore-hash data)) ;; '() (hash-table-keys (d:alldat-status-ignore-hash data)) ;; '() #f #f @@ -1218,11 +1225,12 @@ (d:alldat-hide-not-hide data) #f #f "id,testname,item_path,state,status" (if (d:alldat-filters-changed data) 0 - last-update))) + last-update) + *dashboard-mode*)) '()))) ;; get 'em all (debug:print 0 "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) (sort tdat (lambda (a b) (let* ((aval (vector-ref a 2)) (bval (vector-ref b 2)) @@ -1595,26 +1603,28 @@ #:title "state/status filter" (iup:vbox (apply iup:hbox (map (lambda (status) - (iup:toggle status #:action (lambda (obj val) - (mark-for-update) - (if (eq? val 1) - (hash-table-set! (d:alldat-status-ignore-hash data) status #t) - (hash-table-delete! (d:alldat-status-ignore-hash data) status)) - (set-bg-on-filter)))) + (iup:toggle (conc status " ") + #:action (lambda (obj val) + (mark-for-update) + (if (eq? val 1) + (hash-table-set! (d:alldat-status-ignore-hash data) status #t) + (hash-table-delete! (d:alldat-status-ignore-hash data) status)) + (set-bg-on-filter)))) (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) (apply iup:hbox (map (lambda (state) - (iup:toggle state #:action (lambda (obj val) - (mark-for-update) - (if (eq? val 1) - (hash-table-set! (d:alldat-state-ignore-hash data) state #t) - (hash-table-delete! (d:alldat-state-ignore-hash data) state)) - (set-bg-on-filter)))) + (iup:toggle (conc state " ") + #:action (lambda (obj val) + (mark-for-update) + (if (eq? val 1) + (hash-table-set! (d:alldat-state-ignore-hash data) state #t) + (hash-table-delete! (d:alldat-state-ignore-hash data) state)) + (set-bg-on-filter)))) (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) (maxruns (d:alldat-tot-runs data))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -2162,11 +2162,14 @@ ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; 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 dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update) +;; mode: +;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states ) +;; +(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) (if (not (number? run-id)) (begin ;; no need to treat this as an error by default (debug:print 4 "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) '()) @@ -2177,27 +2180,33 @@ (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 - " NOT IN ('" - " IN ('") + (if (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('")) (string-intersperse states "','") "')"))) (statuses-qry (if (null? statuses) #f (conc " status " - (if not-in - " NOT IN ('" - " IN ('") + (if (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('") ) (string-intersperse statuses "','") "')"))) (states-statuses-qry (cond ((and states-qry statuses-qry) - (conc " AND ( " states-qry " AND " statuses-qry " ) ")) + (case mode + ((dashboard)(conc " AND " (if not-in "NOT " "") "( ( state='COMPLETED' AND " statuses-qry " ) OR " states-qry " ) ")) + (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) (states-qry (conc " AND " states-qry)) (statuses-qry (conc " AND " statuses-qry)) (else ""))) @@ -2205,11 +2214,11 @@ (qry (conc "SELECT " qryvalstr " FROM tests WHERE run_id=? " (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? states-statuses-qry (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (if last-update (conc " AND last_update > " last-update " ") "") + (if last-update (conc " AND last_update >= " last-update " ") "") (case sort-by ((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 ") @@ -2298,11 +2307,11 @@ (let ((res '())) (for-each (lambda (run-id) (set! res (append res - (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals)))) + (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals #f 'normal)))) (if run-ids run-ids (db:get-all-run-ids dbstruct))) res)) @@ -3311,11 +3320,11 @@ (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 dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f))) + (let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal))) (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) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -747,10 +747,14 @@ (begin (set! *configdat* (car first-pass)) (set! *configinfo* first-pass) (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it (set! toppath *toppath*) + (if (not *toppath*) + (begin + (debug:print "ERROR: you are not in a megatest area!") + (exit 1))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it (let* ((keys (rmt:get-keys)) (key-vals (keys:target->keyval keys target)) (linktree (or (getenv "MT_LINKTREE") Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -1115,11 +1115,12 @@ ;; use qryvals if test-spec provided (if tests-spec (string-intersperse adj-tests-spec ",") ;; db:test-record-fields #f) - #f) + #f + 'normal) '()))) (case dmode ((json ods) (if runs-spec (for-each Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -67,20 +67,20 @@ ;;====================================================================== ;; T E S T S ;;====================================================================== (define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)(last-update #f)) - (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update)) + (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal)) (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 (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update) + (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal) full-list new-offset limit)) full-list)))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -386,13 +386,13 @@ (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) (define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) -(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update) +(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) (if (number? run-id) - (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update)) + (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)) (begin (debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) (print-call-chain (current-error-port)) '()))) @@ -619,11 +619,11 @@ ;; 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 (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f))) + (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal))) (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