@@ -48,19 +48,21 @@ "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2016 Usage: dashboard [options] - -h : this help - -server host:port : connect to host:port instead of db access - -test run-id,test-id : control test identified by testid - -xterm run-id,test-id : Start a new xterm with specified run-id and test-id - -guimonitor : control panel for runs + -h : this help + -test run-id,test-id : control test identified by testid + -skip-version-check : skip the version check Misc -rows N : set number of rows ")) + +;; -server host:port : connect to host:port instead of db access +;; -xterm run-id,test-id : Start a new xterm with specified run-id and test-id +;; -guimonitor : control panel for runs ;; process args (define remargs (args:get-args (argv) (list "-rows" @@ -76,10 +78,11 @@ "-guimonitor" "-main" "-v" "-q" "-use-local" + "-skip-version-check" ) args:arg-hash 0)) (if (args:get-arg "-h") @@ -133,11 +136,11 @@ (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) - (debug:print 0 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) + (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) (for-each (lambda (updater) (debug:print 3 *default-log-port* "Running " updater) (updater) ) @@ -155,37 +158,50 @@ (cons updater curr-updaters)))) ;; data for each specific tab goes here ;; (defstruct dboard:tabdat - allruns - allruns-by-id + ;; runs + allruns ;; list of dboard:rundat records + allruns-by-id ;; hash of run-id -> dboard:rundat records + header ;; header for decoding the run records + keys ;; keys for this run (i.e. target components) + numruns + + ;; Runs view buttondat + item-test-names + + ;; Canvas and drawing data cnv cnv-obj + drawing + draw-cache ;; + + ;; Controls used to launch runs etc. command command-tb - curr-run-id - curr-test-ids - db + + ;; Selector variables + curr-run-id ;; current row to display in Run summary view + curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard + filters-changed ;; to to indicate that the user changed filters for this tab + hide-empty-runs + hide-not-hide ;; toggle for hide/not hide empty runs + hide-not-hide-button + + ;; db info to file the .db files for the area dbdir dbfpath dbkeys - drawing - filters-changed - header - hide-empty-runs - hide-not-hide ;; toggle for hide/not hide - hide-not-hide-button - item-test-names - keys last-db-update ;; last db file timestamp - last-update ;; last time rmt:get-tests-for-run was used to get data - logs-textbox - monitor-db-path + monitor-db-path ;; where to find monitor.db + + ;; tests data + last-update ;; last time rmt:get-tests-for-run was used to get data num-tests - numruns + path-run-ids ro run-keys run-name runs @@ -277,11 +293,12 @@ ;; used to keep the rundata from rmt:get-tests-for-run ;; in sync. ;; (defstruct dboard:rundat run - tests + tests-drawn + tests key-vals last-update ) (define (dboard:runsdat-make-init) @@ -1058,10 +1075,20 @@ #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) + + + + + ;; change this to store run-path appropriately as selector + + + + + (run-id (tree-path->run-id tabdat (cdr run-path)))) (print "run-path: " run-path) (if (number? run-id) (begin (dboard:tabdat-curr-run-id-set! tabdat run-id) @@ -2331,11 +2358,14 @@ (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))))) - (tb (dboard:tabdat-runs-tree tabdat))) + (tb (dboard:tabdat-runs-tree tabdat)) + (num-runs (length (hash-table-keys runs-hash))) + (run-num 0) + (update-start-time (current-seconds))) ;; fill in the tree (if tb (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) @@ -2354,17 +2384,20 @@ userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids)) + ;; (if (and tabdat (dboard:tabdat-view-changed tabdat)) (let* ((drawing (dboard:tabdat-drawing tabdat)) - (runslib (vg:get/create-lib drawing "runslib"))) ;; creates and adds lib + (runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib + (compute-start (current-seconds))) (vg:drawing-xoff-set! drawing (dboard:tabdat-xadj tabdat)) (vg:drawing-yoff-set! drawing (dboard:tabdat-yadj tabdat)) - (update-rundat tabdat + (print "Updating rundat") + (time (update-rundat tabdat "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 100 ;; (dboard:tabdat-numruns tabdat) "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") (let ((res '())) @@ -2371,11 +2404,11 @@ (for-each (lambda (key) (if (not (equal? key "runname")) (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) (if val (set! res (cons (list key val) res)))))) (dboard:tabdat-dbkeys tabdat)) - res)) + res))) (let ((allruns (dboard:tabdat-allruns tabdat)) (rowhash (make-hash-table)) ;; store me in tabdat (cnv (dboard:tabdat-cnv tabdat))) (print "allruns: " allruns) (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) @@ -2403,11 +2436,15 @@ (run-duration (- run-end run-start)) (timescale (/ (- sizex (* 2 canvas-margin)) (if (> run-duration 0) run-duration (current-seconds)))) ;; a least lously guess - (maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset))))) + (maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset)))) + (num-tests (length hierdat)) + (test-num 0) + (tot-tests (length testsdat))) + (set! run-num (+ run-num 1)) ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx) (vg:add-comp-to-lib runslib run-full-name runcomp) (set! run-start-row (+ max-row 2)) (set! start-row run-start-row) ;; this is the run title. move this into the box @@ -2420,11 +2457,13 @@ (for-each (lambda (testdats) (let ((test-objs '()) (iterated (> (length testdats) 1)) (first-rownum #f) - (num-items (length testdats))) + (num-items (length testdats)) + (item-num 0)) + (set! test-num (+ test-num 1)) (for-each (lambda (testdat) (let* ((event-time (maptime (db:test-get-event_time testdat))) (run-duration (* timescale (db:test-get-run_duration testdat))) (end-time (+ event-time run-duration)) @@ -2432,15 +2471,20 @@ (item-path (db:test-get-item-path testdat)) (state (db:test-get-state testdat)) (status (db:test-get-status testdat)) (test-fullname (conc test-name "/" item-path)) (name-color (gutils:get-color-for-state-status state status))) + (set! item-num (+ item-num 1)) ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) + (if (> item-num 50) + (if (eq? 0 (modulo item-num 50)) + (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) (let loop ((rownum run-start-row)) ;; (+ start-row 1))) (set! max-row (max rownum max-row)) ;; track the max row used - (if (dashboard:row-collision rowhash rownum event-time end-time) + (print "Allocating test") + (time (if (dashboard:row-collision rowhash rownum event-time end-time) (loop (+ rownum 1)) (let* ((lly (- sizey (* rownum row-height))) (uly (+ lly row-height)) (obj (vg:make-rect-obj event-time lly end-time uly fill-color: (vg:iup-color->number (car name-color)) @@ -2451,12 +2495,12 @@ (if (not first-rownum) (begin (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items) (set! first-rownum rownum))) (dashboard:add-bar rowhash rownum event-time end-time) - (vg:add-objs-to-comp runcomp obj) - (set! test-objs (cons obj test-objs))))) + (vg:add-obj-to-comp runcomp obj) + (set! test-objs (cons obj test-objs)))))) ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration) )) testdats) ;; If it is an iterated test put box around it now. (if iterated @@ -2464,18 +2508,18 @@ (llx (- (car xtents) 5)) (lly (- (cadr xtents) 10)) (ulx (+ 5 (caddr xtents))) (uly (+ 0 (cadddr xtents)))) (dashboard:add-bar rowhash first-rownum llx ulx num-rows: num-items) - (vg:add-objs-to-comp runcomp (vg:make-rect-obj llx lly ulx uly + (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: (db:test-get-testname (car testdats)) font: "Helvetica -10")))))) hierdat) ;; placeholder box (set! max-row (+ max-row 1)) (let ((y (- sizey (* max-row row-height)))) - (vg:add-objs-to-comp runcomp (vg:make-rect-obj 0 y 0 y))) + (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y))) ;; instantiate the component (let* ((extents (vg:components-get-extents drawing runcomp)) ;; move the following into mapping functions in vg.scm ;; (deltax (- llx ulx)) ;; (scalex (if (> deltax 0)(/ sizex deltax) 1)) @@ -2485,11 +2529,11 @@ (llx (list-ref new-xtnts 0)) (lly (list-ref new-xtnts 1)) (ulx (list-ref new-xtnts 2)) (uly (list-ref new-xtnts 3)) ) ;; (vg:components-get-extents d1 c1))) - (vg:add-objs-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: run-full-name)) + (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: run-full-name)) (vg:instantiate drawing "runslib" run-full-name run-full-name 0 0)) (set! max-row (+ max-row 1))))) allruns) (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)(dboard:tabdat-cnv tabdat)) ;; cnv-obj) (canvas-clear! (dboard:tabdat-cnv tabdat)) ;; -obj) @@ -2530,11 +2574,11 @@ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) - (common:exit-on-version-changed) + (if (not (args:get-arg "-skip-version-check"))(common:exit-on-version-changed)) (let* ((commondat (dboard:commondat-make))) ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... (cond ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ","))))