Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -393,98 +393,10 @@ #:expand "HORIZONTAL" #:action (lambda (obj) (iup:destroy! dlog))))))) dlog)) -;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! -;; -;; get a pretty table to summarize steps -;; -(define (dashboard-tests:process-steps-table steps);; db test-id #!key (work-area #f)) -;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) - ;; organise the steps for better readability - (let ((res (make-hash-table))) - (for-each - (lambda (step) - (debug:print 6 "step=" step) - (let ((record (hash-table-ref/default - res - (tdb:step-get-stepname step) - ;; stepname start end status Duration Logfile - (vector (tdb:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record - "\nid: " (tdb:step-get-id step) - "\nstepname: " (tdb:step-get-stepname step) - "\nstate: " (tdb:step-get-state step) - "\nstatus: " (tdb:step-get-status step) - "\ntime: " (tdb:step-get-event_time step)) - (case (string->symbol (tdb:step-get-state step)) - ((start)(vector-set! record 1 (tdb:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") - (tdb:step-get-status step))) - (if (> (string-length (tdb:step-get-logfile step)) - 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) - ((end) - (vector-set! record 2 (any->number (tdb:step-get-event_time step))) - (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) - ", startt=" startt ", endt=" endt - ", get-status: " (tdb:step-get-status step)) - (if (and (number? startt)(number? endt)) - (seconds->hr-min-sec (- endt startt)) "-1"))) - (if (> (string-length (tdb:step-get-logfile step)) - 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) - (else - (vector-set! record 2 (tdb:step-get-state step)) - (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (tdb:step-get-event_time step)))) - (hash-table-set! res (tdb:step-get-stepname step) record) - (debug:print 6 "record(after) = " record - "\nid: " (tdb:step-get-id step) - "\nstepname: " (tdb:step-get-stepname step) - "\nstate: " (tdb:step-get-state step) - "\nstatus: " (tdb:step-get-status step) - "\ntime: " (tdb:step-get-event_time step)))) - ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) - (sort steps (lambda (a b) - (cond - ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) - ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) - (< (tdb:step-get-id a) (tdb:step-get-id b))) - (else #f))))) - res)) - -(define (dashboard-tests:get-compressed-steps dbstruct run-id test-id) - (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) - (comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) - (map (lambda (x) - ;; take advantage of the \n on time->string - (vector - (vector-ref x 0) - (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) - (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) - (vector-ref x 3) ;; status - (vector-ref x 4) - (vector-ref x 5))) ;; time delta - (sort (hash-table-values comprsteps) - (lambda (a b) - (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1))) - (if (and (number? time-a)(number? time-b)) - (if (< time-a time-b) - #t - (if (eq? time-a time-b) - (string rownum max-row)(set! max-row rownum)) - (let ((val (vector-ref hed (- colnum 1))) - (mtrx-rc (conc rownum ":" colnum))) - (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) - (if (< colnum 6) - (loop hed tal rownum (+ colnum 1)) - (if (not (null? tal)) - (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) - (if (> max-row 0) - (begin - ;; we are going to speculatively clear rows until we find a row that is already cleared - (let loop ((rownum (+ max-row 1)) - (colnum 0) - (deleted #f)) - ;; (debug:print-info 0 "cleaning " rownum ":" colnum) - (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum)) - (next-col (if (eq? colnum 6) 1 (+ colnum 1))) - (mtrx-rc (conc rownum ":" colnum)) - (curr-val (iup:attribute steps-matrix mtrx-rc))) - ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) - (if (and (string? curr-val) - (not (equal? curr-val ""))) - (begin - (iup:attribute-set! steps-matrix mtrx-rc "") - (loop next-row next-col #t)) - (if (eq? colnum 6) ;; not done, didn't get a full blank row - (if deleted (loop next-row next-col #f)) ;; exit on this not met - (loop next-row next-col deleted))))) - (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))))) + (dcommon:populate-steps teststeps steps-matrix)))) (hash-table-set! widgets "StepsMatrix" proc) (proc testdat)) steps-matrix) ;; populate the Test Data panel (iup:frame Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1045,11 +1045,11 @@ #:click-cb (lambda (obj lin col status) (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) - (cmd (conc toolpath " -test " test-id "&"))) + (cmd (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&"))) (system cmd))))) (updater (lambda () (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #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*)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1806,14 +1806,13 @@ ;; (define (db:get-test-info-by-ids dbstruct run-id test-ids) (let ((db (db:get-db dbstruct run-id)) (res '())) (sqlite3:for-each-row - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id) + (lambda (a . b) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id) - res))) + (set! res (cons (apply vector a b) res))) (db:get-db dbstruct run-id) (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) res)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -228,15 +228,20 @@ (fullname (conc testname "/" itempath)) (dispname (if (string=? itempath "") testname (conc " " itempath))) (rownum (hash-table-ref/default testname-to-row fullname #f)) (test-path (append run-path (if (equal? itempath "") (list testname) - (list testname itempath))))) + (list testname itempath)))) + (tb (dboard:data-get-tests-tree *data*))) (print "INFONOTE: run-path: " run-path) (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" test-path userdata: (conc "test-id: " test-id)) + (let ((node-num (tree:find-node tb (cons "Runs" test-path))) + (color (car (gutils:get-color-for-state-status state status)))) + (debug:print 0 "node-num: " node-num ", color: " color) + (iup:attribute-set! tb (conc "COLOR" node-num) color)) (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) (if (not rownum) (let ((rownums (hash-table-values testname-to-row))) (set! rownum (if (null? rownums) 1 @@ -632,5 +637,135 @@ (if (not (null? tal)) ;; leave a column of space to the right to list items (loop (car tal) (cdr tal)))))))) +;;====================================================================== +;; S T E P S +;;====================================================================== + +;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! +;; +;; get a pretty table to summarize steps +;; +(define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f)) +;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) + ;; organise the steps for better readability + (let ((res (make-hash-table))) + (for-each + (lambda (step) + (debug:print 6 "step=" step) + (let ((record (hash-table-ref/default + res + (tdb:step-get-stepname step) + ;; stepname start end status Duration Logfile + (vector (tdb:step-get-stepname step) "" "" "" "" "")))) + (debug:print 6 "record(before) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)) + (case (string->symbol (tdb:step-get-state step)) + ((start)(vector-set! record 1 (tdb:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (tdb:step-get-status step))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (tdb:step-get-event_time step))) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (tdb:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1"))) + (if (> (string-length (tdb:step-get-logfile step)) + 0) + (vector-set! record 5 (tdb:step-get-logfile step)))) + (else + (vector-set! record 2 (tdb:step-get-state step)) + (vector-set! record 3 (tdb:step-get-status step)) + (vector-set! record 4 (tdb:step-get-event_time step)))) + (hash-table-set! res (tdb:step-get-stepname step) record) + (debug:print 6 "record(after) = " record + "\nid: " (tdb:step-get-id step) + "\nstepname: " (tdb:step-get-stepname step) + "\nstate: " (tdb:step-get-state step) + "\nstatus: " (tdb:step-get-status step) + "\ntime: " (tdb:step-get-event_time step)))) + ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) + ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) + (< (tdb:step-get-id a) (tdb:step-get-id b))) + (else #f))))) + res)) + +(define (dcommon:get-compressed-steps dbstruct run-id test-id) + (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) + (comprsteps (dcommon:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) + (map (lambda (x) + ;; take advantage of the \n on time->string + (vector + (vector-ref x 0) + (let ((s (vector-ref x 1))) + (if (number? s)(seconds->time-string s) s)) + (let ((s (vector-ref x 2))) + (if (number? s)(seconds->time-string s) s)) + (vector-ref x 3) ;; status + (vector-ref x 4) + (vector-ref x 5))) ;; time delta + (sort (hash-table-values comprsteps) + (lambda (a b) + (let ((time-a (vector-ref a 1)) + (time-b (vector-ref b 1))) + (if (and (number? time-a)(number? time-b)) + (if (< time-a time-b) + #t + (if (eq? time-a time-b) + (string rownum max-row)(set! max-row rownum)) + (let ((val (vector-ref hed (- colnum 1))) + (mtrx-rc (conc rownum ":" colnum))) + (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) + (if (< colnum 6) + (loop hed tal rownum (+ colnum 1)) + (if (not (null? tal)) + (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) + (if (> max-row 0) + (begin + ;; we are going to speculatively clear rows until we find a row that is already cleared + (let loop ((rownum (+ max-row 1)) + (colnum 0) + (deleted #f)) + ;; (debug:print-info 0 "cleaning " rownum ":" colnum) + (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum)) + (next-col (if (eq? colnum 6) 1 (+ colnum 1))) + (mtrx-rc (conc rownum ":" colnum)) + (curr-val (iup:attribute steps-matrix mtrx-rc))) + ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) + (if (and (string? curr-val) + (not (equal? curr-val ""))) + (begin + (iup:attribute-set! steps-matrix mtrx-rc "") + (loop next-row next-col #t)) + (if (eq? colnum 6) ;; not done, didn't get a full blank row + (if deleted (loop next-row next-col #f)) ;; exit on this not met + (loop next-row next-col deleted))))) + (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use format) +(use format numbers) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use sqlite3 srfi-1 posix regex regex-case srfi-69) @@ -324,13 +324,13 @@ #:numlin 5 #:numcol-visible 1 #:numlin-visible 5)) (steps-matrix (iup:matrix #:expand "YES" - #:numcol 5 + #:numcol 6 #:numlin 50 - #:numcol-visible 5 + #:numcol-visible 6 #:numlin-visible 8)) (data-matrix (iup:matrix #:expand "YES" #:numcol 8 #:numlin 50 @@ -359,11 +359,12 @@ (iup:attribute-set! steps-matrix "0:2" "Start") (iup:attribute-set! steps-matrix "0:3" "End") (iup:attribute-set! steps-matrix "WIDTH3" "50") (iup:attribute-set! steps-matrix "0:4" "Status") (iup:attribute-set! steps-matrix "WIDTH4" "50") - (iup:attribute-set! steps-matrix "0:5" "Log File") + (iup:attribute-set! steps-matrix "0:5" "Duration") + (iup:attribute-set! steps-matrix "0:6" "Log File") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") ;; (iup:attribute-set! steps-matrix "WIDTH1" "120") ;; (iup:attribute-set! steps-matrix "WIDTH0" "100") @@ -446,14 +447,18 @@ ;; get test-id ;; then get test record (if testdat (let* ((test-id (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f)) (test-data (hash-table-ref/default testdat test-id #f)) + (run-id (db:test-get-run_id test-data)) (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) - (db:test-get-run_id test-data) '())) + run-id + '())) (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) - (runname (if (null? targ/runname) "" (car (cdr targ/runname))))) + (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) + (steps-dat (dcommon:get-compressed-steps *dbstruct-local* run-id test-id))) + (if test-data (begin ;; (for-each (lambda (data) @@ -494,14 +499,15 @@ (db:test-get-uname test-data) (db:test-get-diskfree test-data) (db:test-get-cpuload test-data) (seconds->hr-min-sec (db:test-get-run_duration test-data))) (make-list 5 ""))) + )) + (dcommon:populate-steps steps-dat steps-matrix)))))) ;;(list meta-dat-matrix ;; (if test-id ;; (list ( - ))))))) ;; db:test-get-id ;; db:test-get-run_id ;; db:test-get-testname Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -166,10 +166,13 @@ cd fullrun;$(BINPATH)/dashboard -rows 15 & dashboard : cleanprep cd fullrun && $(BINPATH)/dashboard -rows $(ROWS) & +newdashboard : cleanprep + cd fullrun && $(BINPATH)/newdashboard & + remove : cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath % clean : rm cleanprep Index: tree.scm ================================================================== --- tree.scm +++ tree.scm @@ -88,10 +88,11 @@ (nodenum (tree:find-node obj newpath))) ;; Add the branch under lastnode if not found (if (not nodenum) (begin (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) + ;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE? (if userdata (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) (if (null? tal) #t ;; reset to top @@ -112,10 +113,15 @@ (newpath (append trimpath (list node-title)))) (if (>= currnode nodenum) newpath (loop (+ currnode 1) newpath))))) + +(define (tree:delete-node obj top node-path) ;; node-path is a list of strings + (let ((id (tree:find-node obj (cons top node-path)))) + (print "Found node to remove " id " for path " top " " node-path) + (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED"))) #| (let* ((tb (iup:treebox #:value 0