Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -504,10 +504,11 @@ ;;====================================================================== ;; R U N S ;;====================================================================== +;; keys list to key1,key2,key3 ... (define (runs:get-std-run-fields keys remfields) (let* ((header (append (map key:get-fieldname keys) remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -25,10 +25,11 @@ (declare (uses server)) (declare (uses synchash)) (include "common_records.scm") (include "db_records.scm") +(include "key_records.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2011 @@ -284,10 +285,12 @@ (define (tests) (iup:hbox (iup:frame #:title "Tests browser"))) +(define *runs-matrix* #f) + (define (runs) (let* ((runs-matrix (iup:matrix #:expand "YES" ;; #:fittosize "YES" #:scrollbar "YES" @@ -341,11 +344,11 @@ ) (list runs-matrix)) ;; (iup:attribute-set! validvals-matrix "WIDTH1" "290") ;; (iup:attribute-set! envovrd-matrix "WIDTH1" "290") - + (set! *runs-matrix* runs-matrix) (iup:hbox (iup:frame #:title "Runs browser" (iup:vbox runs-matrix))))) @@ -368,26 +371,105 @@ ;;====================================================================== ;; Process runs ;;====================================================================== +(define *data* (make-hash-table)) +(hash-table-set! *data* "runid-to-col" (make-hash-table)) +(hash-table-set! *data* "testname-to-row" (make-hash-table)) + ;; TO-DO ;; 1. Make "data" hash-table hierarchial store of all displayed data ;; 2. Update synchash to understand "get-runs", "get-tests" etc. ;; 3. Add extraction of filters to synchash calls ;; -(define (run-update data runname keypatts testpatt states statuses) +;; Mode is 'full or 'incremental for full refresh or incremental refresh +(define (run-update keys data runname keypatts testpatt states statuses mode) (let* (;; count and offset => #f so not used ;; the synchash calls modify the "data" hash (run-changes (synchash:client-get 'db:get-runs "get-runs" (length keypatts) data runname #f #f keypatts)) ;; Now can calculate the run-ids (run-hash (hash-table-ref/default data "get-runs" #f)) (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) - ;; (debug:print-info 2 "run-hash-keys: " (hash-table-keys run-hash)) - ;; (debug:print-info 2 "run-hash: ")(pp (hash-table->alist run-hash)) - ;; (debug:print-info 2 "run-ids: " run-ids) - (test-changes (synchash:client-get 'db:get-tests-for-runs "get-tests-for-runs" 0 data run-ids testpatt states statuses))) + (test-changes (synchash:client-get 'db:get-tests-for-runs "get-tests-for-runs" 0 data run-ids testpatt states statuses)) + (runs-hash (hash-table-ref/default data "get-runs" #f)) + (header (hash-table-ref/default runs-hash "header" #f)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (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 header "event_time")) + (time-b (db:get-value-by-header record-b header "event_time"))) + (> time-a time-b))) + )) + (runid-to-col (hash-table-ref *data* "runid-to-col")) + (testname-to-row (hash-table-ref *data* "testname-to-row")) + (colnum 1) + (rownum 0)) ;; rownum = 0 is the header + ;; tests related stuff + ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) + + ;; Given a run-id and testname/item_path calculate a cell R:C + + + ;; Each run is unique on its keys and runname or run-id, store in hash on colnum + (for-each (lambda (run-id) + (let* (;; (run-id (db:get-value-by-header rundat header "id")) + (run-record (hash-table-ref/default runs-hash run-id #f)) + (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) + (map key:get-fieldname keys))) + (run-name (db:get-value-by-header run-record header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name))) + (iup:attribute-set! *runs-matrix* (conc rownum ":" colnum) col-name) + (hash-table-set! runid-to-col run-id (list colnum run-record)) + (set! colnum (+ colnum 1)))) + run-ids) + + ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table + ;; Do this analysis in the order of the run-ids, the most recent run wins + (for-each (lambda (run-id) + (let* ((new-test-dat (car test-changes)) + (removed-tests (cadr test-changes)) + (tests (sort (map cadr (filter (lambda (testrec) + (eq? run-id (db:test-get-run_id (cadr testrec)))) + new-test-dat)) + (lambda (a b) + (let ((time-a (db:test-get-event_time a)) + (time-b (db:test-get-event_time b))) + (> time-a time-b))))) + ;; test-changes is a list of (( id record ) ... ) + ;; Get list of test names sorted by time, remove tests + (test-names (delete-duplicates (map db:test-get-testname tests))) + (colnum (car (hash-table-ref runid-to-col run-id)))) + ;; for each test name get the slot if it exists and fill in the cell + ;; or take the next slot and fill in the cell, deal with items in the + ;; run view panel? The run view panel can have a tree selector for + ;; browsing the tests/items + (for-each (lambda (test) + (let* ((state (db:test-get-state test)) + (status (db:test-get-status test)) + (testname (db:test-get-testname test)) + (rownum (hash-table-ref/default testname-to-row testname #f))) + (if (not rownum) + (let ((rownums (hash-table-values testname-to-row))) + (set! rownum (if (null? rownums) + 1 + (+ 1 (apply max rownums)))) + (hash-table-set! testname-to-row testname rownum ) + ;; create the label + (iup:attribute-set! *runs-matrix* (conc rownum ":" 0) testname) + )) + ;; set the cell text and color + ;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status) + (iup:attribute-set! *runs-matrix* (conc rownum ":" colnum) status) + (iup:attribute-set! *runs-matrix* (conc "BGCOLOR" rownum ":" colnum) (gutils:get-color-for-state-status state status)) + )) + tests))) + run-ids) + + ;; (debug:print 2 "run-changes: " run-changes) + ;; (debug:print 2 "test-changes: " test-changes) (list run-changes test-changes))) (define (newdashboard) (let* ((data (make-hash-table)) (keys (cdb:remote-run db:get-keys #f)) @@ -398,10 +480,10 @@ (statuses '())) (iup:show (main-panel)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) - (let ((changes (run-update data runname keypatts testpatt states statuses))) - (debug:print 0 "CHANGES: " changes)))))) + (let ((changes (run-update keys data runname keypatts testpatt states statuses 'full))) + (debug:print 0 "CHANGE(S): " (car changes) "...")))))) (newdashboard) (iup:main-loop) Index: synchash.scm ================================================================== --- synchash.scm +++ synchash.scm @@ -81,11 +81,11 @@ newdat) (for-each (lambda (id) (hash-table-delete! myhash id)) removs) - synchash)) + (list newdat removs))) ;; synchash)) (define *synchashes* (make-hash-table)) (define (synchash:server-get db proc synckey keynum . params)