Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -979,10 +979,14 @@ (define (seconds->year-work-week/day-time sec) (time->string (seconds->local-time sec) "%Yww%V.%w %H:%M")) +(define (seconds->year-week/day-time sec) + (time->string + (seconds->local-time sec) "%Yw%V.%w %H:%M")) + (define (seconds->quarter sec) (case (string->number (time->string (seconds->local-time sec) "%m")) @@ -989,10 +993,46 @@ ((1 2 3) 1) ((4 5 6) 2) ((7 8 9) 3) ((10 11 12) 4) (else #f))) + +;; given span of seconds tstart to tend +;; find start time to mark and mark delta +;; +(define (common:find-start-mark-and-mark-delta tstart tend) + (let* ((deltat (- tend tstart)) + (result #f) + (min 60) + (hr (* 60 60)) + (day (* 24 hr)) + (yr (* 365 day)) ;; year + (mo (/ yr 12)) + (wk (* day 7))) + (for-each + (lambda (max-blks) + (for-each + (lambda (span) ;; 5 2 1 + (if (not result) + (for-each + (lambda (timeunit timesym) ;; year month day hr min sec + (if (not result) + (let* ((time-blk (* span timeunit)) + (num-blks (quotient deltat time-blk))) + (if (and (> num-blks 4)(< num-blks max-blks)) + (let ((first (* (quotient tstart time-blk) time-blk))) + (set! result (list span timeunit time-blk first timesym)) + ))))) + (list yr mo wk day hr min 1) + '( y mo w d h m s)))) + (list 8 6 5 2 1))) + '(5 10 15 20 30 40 50 500)) + (if values + (apply values result) + (values 0 day 1 0 'd)))) + + ;;====================================================================== ;; C O L O R S ;;====================================================================== Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -14,10 +14,11 @@ ;;====================================================================== (use regex regex-case) ;; directory-utils) (declare (unit configf)) (declare (uses process)) +(declare (uses env)) (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -54,11 +54,12 @@ -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 + -rows R : set number of rows + -cols C : set number of columns ")) ;; -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 @@ -65,10 +66,11 @@ ;; process args (define remargs (args:get-args (argv) (list "-rows" + "-cols" "-run" "-test" "-xterm" "-debug" "-host" @@ -140,14 +142,12 @@ 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) - ) - + ;; (debug:print 3 *default-log-port* "Running " updater) + (updater)) updaters)))) ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num ;; (define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) @@ -166,23 +166,27 @@ ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records ((done-runs '()) : list) ;; list of runs already drawn ((not-done-runs '()) : list) ;; list of runs not yet drawn (header #f) ;; header for decoding the run records (keys #f) ;; keys for this run (i.e. target components) - ((numruns 16) : number) ;; + ((numruns (string->number (or (args:get-arg "-cols") "8"))) : number) ;; ((tot-runs 0) : number) ((last-data-update 0) : number) ;; last time the data in allruns was updated (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects ;; Runs view ((buttondat (make-hash-table)) : hash-table) ;; - ((item-test-names '()) : list) + ((item-test-names '()) : list) ;; list of itemized tests ((run-keys (make-hash-table)) : hash-table) (runs-matrix #f) ;; used in newdashboard ((start-run-offset 0) : number) ;; left-right slider value ((start-test-offset 0) : number) ;; up-down slider value - + ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x14")) : string) ;; was 12 + ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 + ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50 + ((all-test-names '()) : list) + ;; Canvas and drawing data (cnv #f) (cnv-obj #f) (drawing #f) ((run-start-row 0) : number) @@ -203,17 +207,17 @@ statuses ;; statuses for -status s1,s2 ... ;; 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 #f) : boolean) ;; to to indicate that the user changed filters for this tab - ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters - ((hide-empty-runs #f) : boolean) - ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs + ((filters-changed #f) : boolean) ;; to to indicate that the user changed filters for this tab + ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters + ((hide-empty-runs #f) : boolean) + ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs (hide-not-hide-button #f) - ((searchpatts (make-hash-table)) : hash-table) ;; - ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control + ((searchpatts (make-hash-table)) : hash-table) ;; + ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f (target #f) (test-patts #f) ;; db info to file the .db files for the area @@ -250,33 +254,10 @@ (define (dboard:tabdat-test-patts-set!-use vec val) (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) (define (dboard:tabdat-make-data) (let ((dat (make-dboard:tabdat))) - ;; curr-test-ids: (make-hash-table) - ;; command: "" - ;; dbdir: #f - ;; filters-changed: #f - ;; hide-empty-runs: #f - ;; hide-not-hide-button: #f - ;; hide-not-hide: #t - ;; key-listboxes: #f - ;; last-db-update: 0 - ;; num-tests: 15 - ;; originx: #f - ;; originy: #f - ;; path-run-ids: (make-hash-table) - ;; run-ids: (make-hash-table) - ;; run-keys: (make-hash-table) - ;; searchpatts: (make-hash-table) - ;; start-test-offset: 0 - ;; state-ignore-hash: (make-hash-table) - ;; status-ignore-hash: (make-hash-table) - ;; xadj: 0 - ;; yadj: 0 - ;; view-changed: #t - ;; ))) (dboard:setup-tabdat dat) (dboard:setup-num-rows dat) dat)) (define (dboard:setup-tabdat tabdat) @@ -317,11 +298,11 @@ rowsused ;; hash of lists covering what areas used - replace with quadtree hierdat ;; put hierarchial sorted list here tests ;; hash of id => testdat tests-by-name ;; hash of testfullname => testdat key-vals - last-update ;; last query to db got records from before last-update + ((last-update 0) : fixnum) ;; last query to db got records from before last-update data-changed ) (define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f)(last-update -100));; -100 is before time began (make-dboard:rundat @@ -335,14 +316,16 @@ (define (dboard:rundat-copy-tests-to-by-name rundat) (let ((src-ht (dboard:rundat-tests rundat)) (trg-ht (dboard:rundat-tests-by-name rundat))) (if (and (hash-table? src-ht)(hash-table? trg-ht)) - (for-each - (lambda (testdat) - (hash-table-set! trg-ht (test:test-get-fullname testdat) testdat)) - (hash-table-values src-ht)) + (begin + (hash-table-clear! trg-ht) + (for-each + (lambda (testdat) + (hash-table-set! trg-ht (test:test-get-fullname testdat) testdat)) + (hash-table-values src-ht))) (debug:print 0 *default-log-port* "WARNING: src-ht " src-ht " trg-ht " trg-ht)))) (defstruct dboard:testdat id ;; testid state ;; test state @@ -513,11 +496,15 @@ (if (dboard:tabdat-filters-changed tabdat) 0 last-update) ;; last-update *dashboard-mode*)) ;; use dashboard mode (use-new (dboard:tabdat-hide-not-hide tabdat)) - (tests-ht (dboard:rundat-tests run-dat)) + (tests-ht (if (dboard:tabdat-filters-changed tabdat) + (let ((ht (make-hash-table))) + (dboard:rundat-tests-set! run-dat ht) + ht) + (dboard:rundat-tests run-dat))) (start-time (current-seconds))) (for-each (lambda (tdat) (let ((test-id (db:test-get-id tdat)) (state (db:test-get-state tdat))) @@ -524,11 +511,12 @@ (dboard:rundat-data-changed-set! run-dat #t) (if (equal? state "DELETED") (hash-table-delete! tests-ht test-id) (hash-table-set! tests-ht test-id tdat)))) tmptests) - (dboard:rundat-last-update-set! run-dat (- (current-seconds) 10)) ;; go back two seconds in time to ensure all changes are captured. + (dboard:rundat-last-update-set! run-dat (- (current-seconds) 2)) ;; go back two seconds in time to ensure all changes are captured. + ;; (debug:print-info 0 *default-log-port* "tests-ht: " (hash-table-keys tests-ht)) tests-ht)) ;; tmptests - new tests data ;; prev-tests - old tests data ;; @@ -553,48 +541,67 @@ ;; (define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) (header (db:get-header allruns)) (runs (db:get-rows allruns)) - (start-time (current-seconds))) + (start-time (current-seconds)) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run header "id") run)) + runs) ;; (vector-ref runs-dat 1)) + ht)) + (tb (dboard:tabdat-runs-tree tabdat))) (dboard:tabdat-header-set! tabdat header) ;; ;; trim runs to only those that are changing often here ;; - (if (not (null? runs)) + (if (null? runs) + (begin + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-all-test-names-set! tabdat '()) + (dboard:tabdat-item-test-names-set! tabdat '()) + (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) (let loop ((run (car runs)) (tal (cdr runs)) (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) + (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) + (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) (key-vals (rmt:get-key-vals run-id)) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate + ;; dboard:get-tests-for-run-duplicate - returns a hash table + ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) (num-tests (length all-test-ids))) ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) ;; (tests (bubble-up tmptests priority: bubble-type)) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? - (if (not (null? all-test-ids)) - (let* ((newmaxtests (max num-tests maxtests)) - (last-update (- (current-seconds) 10)) - (run-struct (dboard:rundat-make-init - run: run - tests: tests-ht - key-vals: key-vals - last-update: last-update)) - (new-res (cons run-struct res)) - (elapsed-time (- (current-seconds) start-time))) - (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct) - (if (or (null? tal) - (> elapsed-time 5)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update - (begin - (if (> elapsed-time 5)(print "WARNING: timed out in update-testdat " elapsed-time "s")) - (dboard:tabdat-allruns-set! tabdat new-res) - maxtests) - (loop (car tal)(cdr tal) new-res newmaxtests))))))))) + (let* ((newmaxtests (max num-tests maxtests)) + (last-update (- (current-seconds) 10)) + (run-struct (dboard:rundat-make-init + run: run + tests: tests-ht + key-vals: key-vals + last-update: last-update)) + (new-res (if (null? all-test-ids) res (cons run-struct res))) + (elapsed-time (- (current-seconds) start-time))) + (if (null? all-test-ids) + (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) + (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) + (if (or (null? tal) + (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update + (begin + (if (> elapsed-time 2)(print "WARNING: timed out in update-testdat " elapsed-time "s")) + (dboard:tabdat-allruns-set! tabdat new-res) + maxtests) + (loop (car tal)(cdr tal) new-res newmaxtests)))))) + (dboard:tabdat-filters-changed-set! tabdat #f) + (dboard:update-tree tabdat runs-hash header tb))) (define *collapsed* (make-hash-table)) (define (toggle-hide lnum uidat) ; fulltestname) (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) @@ -647,11 +654,11 @@ (if (equal? (vector-ref x 1) "") (vector-ref x 0) (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) vlst2))) -(define (update-labels uidat) +(define (update-labels uidat alltestnames) (let* ((rown 0) (keycol (dboard:uidat-get-keycol uidat)) (lftcol (dboard:uidat-get-lftcol uidat)) (numcols (vector-length lftcol)) (maxn (- numcols 1)) @@ -658,11 +665,11 @@ (allvals (make-vector numcols ""))) (for-each (lambda (name) (if (<= rown maxn) (vector-set! allvals rown name)) ;) (set! rown (+ 1 rown))) - *alltestnamelst*) + alltestnames) (let loop ((i 0)) (let* ((lbl (vector-ref lftcol i)) (keyval (vector-ref keycol i)) (oldval (iup:attribute lbl "TITLE")) (newval (vector-ref allvals i))) @@ -742,42 +749,53 @@ (take-right (dboard:tabdat-allruns tabdat) numruns) (pad-list (dboard:tabdat-allruns tabdat) numruns))) (lftcol (dboard:uidat-get-lftcol uidat)) (tableheader (dboard:uidat-get-header uidat)) (table (dboard:uidat-get-runsvec uidat)) - (coln 0)) - (set! *alltestnamelst* '()) + (coln 0) + (all-test-names (make-hash-table))) + ;; create a concise list of test names + ;; (for-each (lambda (rundat) (if rundat (let* ((testdats (dboard:rundat-tests rundat)) - (testnames (map test:test-get-fullname (hash-table-values testdats))) - (alltests-by-name (make-hash-table))) + (testnames (map test:test-get-fullname (hash-table-values testdats)))) (dboard:rundat-copy-tests-to-by-name rundat) ;; for the normalized list of testnames (union of all runs) (if (not (and (dboard:tabdat-hide-empty-runs tabdat) (null? testnames))) (for-each (lambda (testname) - (if (not (member testname *alltestnamelst*)) - (begin - (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) + (hash-table-set! all-test-names testname #t)) testnames))))) runs) - ;; need alltestnames to enable lining up all tests from all runs - (set! *alltestnamelst* (collapse-rows tabdat *alltestnamelst*)) ;;; argh. please clean up this sillyness - (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) (dboard:tabdat-start-test-offset tabdat)) - (drop *alltestnamelst* (dboard:tabdat-start-test-offset tabdat)) - '()))) - (append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) "")))) - (update-labels uidat) + ;; create the minimize list of testnames to be displayed. Sorting + ;; happens here *before* trimming + ;; + (dboard:tabdat-all-test-names-set! + tabdat + (collapse-rows + tabdat + (sort (hash-table-keys all-test-names) string>?))) ;; FIXME: Sorting needs to happen here + + ;; Trim the names list to fit the matrix of buttons + ;; + (dboard:tabdat-all-test-names-set! + tabdat + (let ((xl (if (> (length (dboard:tabdat-all-test-names tabdat)) (dboard:tabdat-start-test-offset tabdat)) + (drop (dboard:tabdat-all-test-names tabdat) + (dboard:tabdat-start-test-offset tabdat)) + '()))) + (append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) "")))) + (update-labels uidat (dboard:tabdat-all-test-names tabdat)) (for-each (lambda (rundat) + ;; if rundat is junk clobber it with a decent placeholder (if (or (not rundat) ;; handle padded runs (not (dboard:rundat-run rundat))) - ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration (set! rundat (dboard:rundat-make-init key-vals: (map (lambda (x) "")(dboard:tabdat-keys tabdat))))) (let* ((run (dboard:rundat-run rundat)) (testsdat-by-name (dboard:rundat-tests-by-name rundat)) (key-val-dat (dboard:rundat-key-vals rundat)) @@ -786,10 +804,11 @@ (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname"))) (if x x ""))))) (run-key (string-intersperse key-vals "\n"))) ;; fill in the run header key values + ;; (let ((rown 0) (headercol (vector-ref tableheader coln))) (for-each (lambda (kval) (let* ((labl (vector-ref headercol rown))) (if (not (equal? kval (iup:attribute labl "TITLE"))) @@ -796,10 +815,11 @@ (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) (set! rown (+ rown 1)))) key-vals)) ;; For this run now fill in the buttons for each test + ;; (let ((rown 0) (columndat (vector-ref table coln))) (for-each (lambda (testname) (let ((buttondat (hash-table-ref/default (dboard:tabdat-buttondat tabdat) (mkstr coln rown) #f))) @@ -839,11 +859,11 @@ (vector-set! buttondat 1 color) (vector-set! buttondat 2 buttontxt) (vector-set! buttondat 3 testdat) (vector-set! buttondat 4 run-key))) (set! rown (+ rown 1)))) - *alltestnamelst*)) + (dboard:tabdat-all-test-names tabdat))) (set! coln (+ coln 1)))) runs))) (define (mkstr . x) (string-intersperse (map conc x) ",")) @@ -1130,10 +1150,35 @@ ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) ))) + +(define (dboard:runs-tree-browser commondat tabdat) + (let* ((tb (iup:treebox + #:value 0 + #:name "Runs" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + (debug:catch-and-dump + (lambda () + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id tabdat (cdr run-path)))) + (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path) + (dboard:tabdat-layout-update-ok-set! tabdat #f) + (if (number? run-id) + (begin + (dboard:tabdat-curr-run-id-set! tabdat run-id) + (dboard:tabdat-view-changed-set! tabdat #t)) + (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id)))) + "treebox")) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) + (dboard:tabdat-runs-tree-set! tabdat tb) + tb)) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; @@ -1169,37 +1214,18 @@ (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num) (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" #:value 150 (iup:vbox - (let* ((tb (iup:treebox - #:value 0 - #:name "Runs" - #:expand "YES" - #:addexpanded "NO" - #:selection-cb - (lambda (obj id state) - (debug:catch-and-dump - (lambda () - (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id tabdat (cdr run-path)))) - (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path) - (if (number? run-id) - (begin - (dboard:tabdat-curr-run-id-set! tabdat run-id) - (dboard:tabdat-view-changed-set! tabdat #t)) - (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id)))) - "treebox")) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) - (dboard:tabdat-runs-tree-set! tabdat tb) - tb) + + (dboard:runs-tree-browser commondat tabdat) + (iup:hbox (iup:toggle "Compact layout" #:fontsize 8 - #:expand "YES" + #:expand "HORIZONTAL" #:value 1 #:action (lambda (obj tstate) (debug:catch-and-dump (lambda () (print "tstate: " tstate) @@ -1252,47 +1278,10 @@ (* scalex -0.02)))))) "wheel-cb")) ))) cnv-obj))))) -;;====================================================================== -;; S U M M A R Y -;;====================================================================== -;; -;; General info about the run(s) and megatest area -(define (dashboard:summary commondat tabdat #!key (tab-num #f)) - (let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) - (changed #f)) - (iup:vbox - (iup:split - #:value 500 - (iup:frame - #:title "General Info" - (iup:vbox - (iup:hbox - (iup:label "Area Path") - (iup:textbox #:value *toppath* #:expand "HORIZONTAL")) - (iup:hbox - (dcommon:keys-matrix rawconfig) - (dcommon:general-info) - ))) - (iup:frame - #:title "Server" - (dcommon:servers-table commondat tabdat))) - (iup:frame - #:title "Megatest config settings" - (iup:hbox - (dcommon:section-matrix rawconfig "setup" "Varname" "Value") - (iup:vbox - (dcommon:section-matrix rawconfig "server" "Varname" "Value") - ;; (iup:frame - ;; #:title "Disks Areas" - (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) - (iup:frame - #:title "Run statistics" - (dcommon:run-stats commondat tabdat tab-num: tab-num))))) - ;;====================================================================== ;; R U N ;;====================================================================== ;; ;; display and manage a single run at a time @@ -1300,13 +1289,10 @@ (define (tree-path->run-id tabdat path) (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) -;; (define dashboard:update-run-summary-tab #f) -;; (define dashboard:update-new-view-tab #f) - (define (dboard:get-tests-dat tabdat run-id last-update) (let ((tdat (if run-id (rmt:get-tests-for-run run-id (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() @@ -1317,31 +1303,64 @@ (if (dboard:tabdat-filters-changed tabdat) 0 last-update) *dashboard-mode*) '()))) ;; get 'em all - (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) + ;; (debug:print 0 *default-log-port* "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)) (anum (string->number aval)) (bnum (string->number bval))) (if (and anum bnum) (< anum bnum) (string<= aval bval))))))) + (define (dashboard:safe-cadr-assoc name lst) (let ((res (assoc name lst))) (if (and res (> (length res) 1)) (cadr res) #f))) +(define (dboard:update-tree tabdat runs-hash runs-header tb) + (let* ((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 runs-header "event_time")) + (time-b (db:get-value-by-header record-b runs-header "event_time"))) + (< time-a time-b))))) + (changed #f) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))) + (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))) + (run-name (db:get-value-by-header run-record runs-header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + (run-path (append key-vals (list run-name))) + (existing (tree:find-node tb run-path))) + (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) + (begin + (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) + ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) + ;; (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" run-path ;; (append key-vals (list run-name)) + 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))) + (define (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix) (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:tabdat-curr-run-id tabdat)) - (last-update 0) ;; fix me + (last-update 0) ;; fix me - have to create and store a rundat record for this (tests-dat (dboard:get-tests-dat tabdat run-id last-update)) (tests-mindat (dcommon:minimize-test-data tests-dat)) (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) (row-indices (cadr indices)) (col-indices (car indices)) @@ -1353,198 +1372,83 @@ (changed #f) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) (vector-ref runs-dat 1)) - ht)) - (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 runs-header "event_time")) - (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (< time-a time-b)))))) + ht))) (dboard:tabdat-filters-changed-set! tabdat #f) (let loop ((pass-num 0) (changed #f)) - ;; (iup:attribute-set! tb "VALUE" "0") - ;; (iup:attribute-set! tb "NAME" "Runs") ;; Update the runs tree - (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))) - (run-name (db:get-value-by-header run-record runs-header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) - (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) - (begin - (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) - ;; (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" run-path ;; (append key-vals (list run-name)) - 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 (eq? pass-num 1) + (dboard:update-tree tabdat runs-hash runs-header tb) + +(if (eq? pass-num 1) (begin ;; big reset - (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS - (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") - (iup:attribute-set! run-matrix "NUMCOL" max-col ) - (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)))) ;; min of 20 - - ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) - ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (and (eq? pass-num 0) changed)) - (set! changed (dcommon:modify-if-different run-matrix key name changed))))) - row-indices) - - (print "row-indices: " row-indices " col-indices: " col-indices) + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! run-matrix "NUMCOL" max-col ) + (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)))) ;; min of 20 + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name))))) + row-indices) + + (print "row-indices: " row-indices " col-indices: " col-indices) (if (and (eq? pass-num 0) changed) (loop 1 #t)) ;; force second pass - ;; Cell contents - (for-each (lambda (entry) - (let* ((row-name (cadr entry)) - (col-name (car entry)) - (valuedat (caddr entry)) - (test-id (list-ref valuedat 0)) - (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 (let ((res (gutils:get-color-for-state-status state status))) - (if (and (list? res) - (> (length res) 1)) - res - #f)))) ;; (list "n/a" "256 256 256")))) - (print "value: " value " row-name: " (cadr value) " row-color: " (car value)) - (print "(assoc row-name row-indices): " (assoc row-name row-indices) " (assoc col-name col-indices): " (assoc col-name col-indices)) - (if value - (let* ((row-name (cadr value)) - (row-color (car value)) - (row-num (dashboard:safe-cadr-assoc row-name row-indices)) ;; (cadr (assoc row-name row-indices))) - (col-num (dashboard:safe-cadr-assoc col-name col-indices)) - (key (conc row-num ":" col-num))) - (if (and row-num col-num) - (begin - (hash-table-set! cell-lookup key test-id) - (set! changed (dcommon:modify-if-different run-matrix key row-name changed)) - (set! changed (dcommon:modify-if-different run-matrix (conc "BGCOLOR" key) row-color changed))) - (print "ERROR: row-num=" row-num " col-num=" col-num)))) - )) - tests-mindat) - - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass due to contents changing - - ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. - - (for-each (lambda (ind) - (print "ind: " ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (set! changed (dcommon:modify-if-different run-matrix key name changed)) - (if changed (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))) - col-indices) + ;; Cell contents + (for-each (lambda (entry) + ;; (print "entry: " entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) + (valuedat (caddr entry)) + (test-id (list-ref valuedat 0)) + (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))) + (hash-table-set! cell-lookup key test-id) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key (cadr value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + tests-mindat) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) + col-indices) (if (and (eq? pass-num 0) changed) (loop 1 #t)) ;; force second pass due to column labels changing ;; (debug:print 0 *default-debug-port* "one-run-updater, changed: " changed " pass-num: " pass-num) (print "one-run-updater, changed: " changed " pass-num: " pass-num) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))) -;; This is the Run Summary tab -;; -(define (dashboard:one-run commondat tabdat #!key (tab-num #f)) - (let* ((tb (iup:treebox - #:value 0 - #:name "Runs" - #:expand "YES" - #:addexpanded "NO" - #: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 tabdat (cdr run-path)))) - (if (number? run-id) - (begin - (dboard:tabdat-curr-run-id-set! tabdat run-id) - ;; (dashboard:update-run-summary-tab) - ) - (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id))) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) - (cell-lookup (make-hash-table)) - (run-matrix (iup:matrix - #:expand "YES" - #: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 " (dboard:tabdat-curr-run-id tabdat) "," test-id "&"))) - (system cmd))))) - (one-run-updater (lambda () - (print "Got here!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!") - (if (dashboard:database-changed? commondat tabdat) - (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix))))) - (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num) - (iup:vbox - (let* ((cnv-obj (iup:canvas - ;; #:size "500x400" - #:expand "YES" - #:scrollbar "YES" - #:posx "0.5" - #:posy "0.5" - #:action (make-canvas-action - (lambda (c xadj yadj) - (debug:catch-and-dump - (lambda () - (if (not (dboard:tabdat-cnv tabdat)) - (dboard:tabdat-cnv-set! tabdat c)) - (let ((drawing (dboard:tabdat-drawing tabdat)) - (old-xadj (dboard:tabdat-xadj tabdat)) - (old-yadj (dboard:tabdat-yadj tabdat))) - (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj))) - (begin - (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) - (dboard:tabdat-view-changed-set! tabdat #t) - (dboard:tabdat-xadj-set! tabdat (* -500 (- xadj 0.5))) - (dboard:tabdat-yadj-set! tabdat (* 500 (- yadj 0.5))) - )))) - "iup:canvas action dashboard:one-run"))) - #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. - (debug:catch-and-dump - (lambda () - (let* ((drawing (dboard:tabdat-drawing tabdat)) - (scalex (vg:drawing-scalex drawing))) - (dboard:tabdat-view-changed-set! tabdat #t) - (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex) - (vg:drawing-scalex-set! drawing - (+ scalex - (if (> step 0) - (* scalex 0.02) - (* scalex -0.02)))))) - "dashboard:one-run wheel-cb")) - ))) - cnv-obj)))) - ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area @@ -1584,180 +1488,13 @@ ;; R U N ;;====================================================================== ;; ;; display and manage a single run at a time -(define (tree-path->run-id tabdat path) - (if (not (null? path)) - (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) - #f)) - ;; (define dashboard:update-run-summary-tab #f) ;; (define dashboard:update-new-view-tab #f) -(define (dboard:get-tests-dat tabdat run-id last-update) - (let ((tdat (if run-id (rmt:get-tests-for-run run-id - (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") - (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() - (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() - #f #f ;; offset limit - (dboard:tabdat-hide-not-hide tabdat) ;; not-in - #f #f ;; sort-by sort-order - #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval - (if (dboard:tabdat-filters-changed tabdat) - 0 - last-update) - *dashboard-mode*) - '()))) ;; get 'em all - (debug:print 0 *default-log-port* "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)) - (anum (string->number aval)) - (bnum (string->number bval))) - (if (and anum bnum) - (< anum bnum) - (string<= aval bval))))))) - -(define (dashboard:safe-cadr-assoc name lst) - (let ((res (assoc name lst))) - (if (and res (> (length res) 1)) - (cadr res) - #f))) - -(define (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix) - (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (run-id (dboard:tabdat-curr-run-id tabdat)) - (last-update 0) ;; fix me - (tests-dat (dboard:get-tests-dat tabdat run-id last-update)) - (tests-mindat (dcommon:minimize-test-data tests-dat)) - (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) - (row-indices (cadr indices)) - (col-indices (car indices)) - (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) - (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window - (numrows 1) - (numcols 1) - (changed #f) - (runs-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - (vector-ref runs-dat 1)) - ht)) - (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 runs-header "event_time")) - (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (< time-a time-b)))))) - (dboard:tabdat-filters-changed-set! tabdat #f) - (let loop ((pass-num 0) - (changed #f)) - ;; (iup:attribute-set! tb "VALUE" "0") - ;; (iup:attribute-set! tb "NAME" "Runs") - ;; Update the runs tree - (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))) - (run-name (db:get-value-by-header run-record runs-header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) - (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) - (begin - (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) - ;; (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" run-path ;; (append key-vals (list run-name)) - 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 (eq? pass-num 1) - (begin ;; big reset - (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS - (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") - (iup:attribute-set! run-matrix "NUMCOL" max-col ) - (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)))) ;; min of 20 - - ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) - ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (and (eq? pass-num 0) changed)) - (set! changed (dcommon:modify-if-different run-matrix key name changed))))) - row-indices) - - (print "row-indices: " row-indices " col-indices: " col-indices) - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass - - ;; Cell contents - (for-each (lambda (entry) - (let* ((row-name (cadr entry)) - (col-name (car entry)) - (valuedat (caddr entry)) - (test-id (list-ref valuedat 0)) - (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 (let ((res (gutils:get-color-for-state-status state status))) - (if (and (list? res) - (> (length res) 1)) - res - #f)))) ;; (list "n/a" "256 256 256")))) - (print "value: " value " row-name: " (cadr value) " row-color: " (car value)) - (print "(assoc row-name row-indices): " (assoc row-name row-indices) " (assoc col-name col-indices): " (assoc col-name col-indices)) - (if value - (let* ((row-name (cadr value)) - (row-color (car value)) - (row-num (dashboard:safe-cadr-assoc row-name row-indices)) ;; (cadr (assoc row-name row-indices))) - (col-num (dashboard:safe-cadr-assoc col-name col-indices)) - (key (conc row-num ":" col-num))) - (if (and row-num col-num) - (begin - (hash-table-set! cell-lookup key test-id) - (set! changed (dcommon:modify-if-different run-matrix key row-name changed)) - (set! changed (dcommon:modify-if-different run-matrix (conc "BGCOLOR" key) row-color changed))) - (print "ERROR: row-num=" row-num " col-num=" col-num)))) - )) - tests-mindat) - - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass due to contents changing - - ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. - - (for-each (lambda (ind) - (print "ind: " ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (set! changed (dcommon:modify-if-different run-matrix key name changed)) - (if changed (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))) - col-indices) - - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass due to column labels changing - - ;; (debug:print 0 *default-debug-port* "one-run-updater, changed: " changed " pass-num: " pass-num) - (print "one-run-updater, changed: " changed " pass-num: " pass-num) - (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))) - ;; This is the Run Summary tab ;; (define (dashboard:one-run commondat tabdat #!key (tab-num #f)) (let* ((tb (iup:treebox #:value 0 @@ -1770,10 +1507,11 @@ (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id tabdat (cdr run-path)))) (if (number? run-id) (begin (dboard:tabdat-curr-run-id-set! tabdat run-id) + (dboard:tabdat-layout-update-ok-set! tabdat #f) ;; (dashboard:update-run-summary-tab) ) (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id))) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) @@ -1786,294 +1524,345 @@ (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id "&"))) (system cmd))))) (one-run-updater (lambda () - (print "Got here!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!") (if (dashboard:database-changed? commondat tabdat) (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix))))) (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:split tb run-matrix))) +;; (iup:vbox +;; (let* ((cnv-obj (iup:canvas +;; ;; #:size "500x400" +;; #:expand "YES" +;; #:scrollbar "YES" +;; #:posx "0.5" +;; #:posy "0.5" +;; #:action (make-canvas-action +;; (lambda (c xadj yadj) +;; (debug:catch-and-dump +;; (lambda () +;; (if (not (dboard:tabdat-cnv tabdat)) +;; (dboard:tabdat-cnv-set! tabdat c)) +;; (let ((drawing (dboard:tabdat-drawing tabdat)) +;; (old-xadj (dboard:tabdat-xadj tabdat)) +;; (old-yadj (dboard:tabdat-yadj tabdat))) +;; (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj))) +;; (begin +;; (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) +;; (dboard:tabdat-view-changed-set! tabdat #t) +;; (dboard:tabdat-xadj-set! tabdat (* -500 (- xadj 0.5))) +;; (dboard:tabdat-yadj-set! tabdat (* 500 (- yadj 0.5))) +;; )))) +;; "iup:canvas action dashboard:one-run"))) +;; #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. +;; (debug:catch-and-dump +;; (lambda () +;; (let* ((drawing (dboard:tabdat-drawing tabdat)) +;; (scalex (vg:drawing-scalex drawing))) +;; (dboard:tabdat-view-changed-set! tabdat #t) +;; (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex) +;; (vg:drawing-scalex-set! drawing +;; (+ scalex +;; (if (> step 0) +;; (* scalex 0.02) +;; (* scalex -0.02)))))) +;; "dashboard:one-run wheel-cb")) +;; ))) +;; cnv-obj)))) + ;; This is the New View tab ;; -(define (dashboard:new-view db commondat tabdat #!key (tab-num #f)) - (let* ((tb (iup:treebox - #:value 0 - #:name "Runs" - #:expand "YES" - #:addexpanded "NO" - #: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 tabdat (cdr run-path)))) - (if (number? run-id) - (begin - (dboard:tabdat-curr-run-id-set! tabdat run-id) - ;; (dashboard:update-new-view-tab) - ) - (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id))) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) - (cell-lookup (make-hash-table)) - (run-matrix (iup:matrix - #:expand "YES" - #: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 " (dboard:tabdat-curr-run-id tabdat) "," test-id "&"))) - (system cmd))))) - (new-view-updater (lambda () - (if (dashboard:database-changed? commondat tabdat) - (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (run-id (dboard:tabdat-curr-run-id tabdat)) - (last-update 0) ;; fix me - (tests-dat (dboard:get-tests-dat tabdat run-id last-update)) - (tests-mindat (dcommon:minimize-test-data tests-dat)) - (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) - (row-indices (cadr indices)) - (col-indices (car indices)) - (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) - (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window - (numrows 1) - (numcols 1) - (changed #f) - (runs-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - (vector-ref runs-dat 1)) - ht)) - (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 runs-header "event_time")) - (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (< 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) - (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))) - (run-name (db:get-value-by-header run-record runs-header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) - (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) - (begin - (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) - ;; (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" run-path ;; (append key-vals (list run-name)) - 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) - (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS - (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") - (iup:attribute-set! run-matrix "NUMCOL" max-col ) - (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 - ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) - ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name))))) - row-indices) - - - ;; Cell contents - (for-each (lambda (entry) - (let* ((row-name (cadr entry)) - (col-name (car entry)) - (valuedat (caddr entry)) - (test-id (list-ref valuedat 0)) - (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))) - (hash-table-set! cell-lookup key test-id) - (if (not (equal? (iup:attribute run-matrix key) (cadr value))) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key (cadr value)) - (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) - tests-mindat) - - ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. - - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name) - (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) - col-indices) - (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))) - (dboard:commondat-add-updater commondat new-view-updater tab-num: tab-num) - (dboard:tabdat-runs-tree-set! tabdat tb) - (iup:split - tb - run-matrix))) +;; (define (dashboard:new-view db commondat tabdat #!key (tab-num #f)) +;; (let* ((tb (iup:treebox +;; #:value 0 +;; #:name "Runs" +;; #:expand "YES" +;; #:addexpanded "NO" +;; #: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 tabdat (cdr run-path)))) +;; (if (number? run-id) +;; (begin +;; (dboard:tabdat-curr-run-id-set! tabdat run-id) +;; ;; (dashboard:update-new-view-tab) +;; (dboard:tabdat-layout-update-ok-set! tabdat #f) +;; ) +;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id))) +;; ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) +;; ))) +;; (cell-lookup (make-hash-table)) +;; (run-matrix (iup:matrix +;; #:expand "YES" +;; #: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 " (dboard:tabdat-curr-run-id tabdat) "," test-id "&"))) +;; (system cmd))))) +;; (new-view-updater (lambda () +;; (if (dashboard:database-changed? commondat tabdat) +;; (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) +;; (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records +;; (run-id (dboard:tabdat-curr-run-id tabdat)) +;; (last-update 0) ;; fix me +;; (tests-dat (dboard:get-tests-dat tabdat run-id last-update)) +;; (tests-mindat (dcommon:minimize-test-data tests-dat)) +;; (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) +;; (row-indices (cadr indices)) +;; (col-indices (car indices)) +;; (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) +;; (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) +;; (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window +;; (numrows 1) +;; (numcols 1) +;; (changed #f) +;; (runs-hash (let ((ht (make-hash-table))) +;; (for-each (lambda (run) +;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) +;; (vector-ref runs-dat 1)) +;; ht)) +;; (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 runs-header "event_time")) +;; (time-b (db:get-value-by-header record-b runs-header "event_time"))) +;; (< 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) +;; (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))) +;; (run-name (db:get-value-by-header run-record runs-header "runname")) +;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) +;; (run-path (append key-vals (list run-name))) +;; (existing (tree:find-node tb run-path))) +;; (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) +;; (begin +;; (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) +;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) +;; ;; (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" run-path ;; (append key-vals (list run-name)) +;; 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) +;; (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS +;; (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") +;; (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") +;; (iup:attribute-set! run-matrix "NUMCOL" max-col ) +;; (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 +;; ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) +;; ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) +;; +;; ;; Row labels +;; (for-each (lambda (ind) +;; (let* ((name (car ind)) +;; (num (cadr ind)) +;; (key (conc num ":0"))) +;; (if (not (equal? (iup:attribute run-matrix key) name)) +;; (begin +;; (set! changed #t) +;; (iup:attribute-set! run-matrix key name))))) +;; row-indices) +;; +;; +;; ;; Cell contents +;; (for-each (lambda (entry) +;; (let* ((row-name (cadr entry)) +;; (col-name (car entry)) +;; (valuedat (caddr entry)) +;; (test-id (list-ref valuedat 0)) +;; (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))) +;; (hash-table-set! cell-lookup key test-id) +;; (if (not (equal? (iup:attribute run-matrix key) (cadr value))) +;; (begin +;; (set! changed #t) +;; (iup:attribute-set! run-matrix key (cadr value)) +;; (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) +;; tests-mindat) +;; +;; ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. +;; +;; (for-each (lambda (ind) +;; (let* ((name (car ind)) +;; (num (cadr ind)) +;; (key (conc "0:" num))) +;; (if (not (equal? (iup:attribute run-matrix key) name)) +;; (begin +;; (set! changed #t) +;; (iup:attribute-set! run-matrix key name) +;; (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) +;; col-indices) +;; (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))) +;; (dboard:commondat-add-updater commondat new-view-updater tab-num: tab-num) +;; (dboard:tabdat-runs-tree-set! tabdat tb) +;; (iup:split +;; tb +;; run-matrix))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (dboard:make-controls commondat tabdat) - (iup:hbox - (iup:vbox - (iup:frame - #:title "filter test and items" - (iup:hbox - (iup:vbox - (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" - #:action (lambda (obj unk val) - (debug:catch-and-dump - (lambda () - (mark-for-update tabdat) - (update-search commondat tabdat "test-name" val)) - "make-controls"))) - (iup:hbox - (iup:button "Quit" #:action (lambda (obj) - ;; (if (dboard:tabdat-dblocal tabdat) (db:close-all (dboard:tabdat-dblocal tabdat))) - (exit))) - (iup:button "Refresh" #:action (lambda (obj) - (mark-for-update tabdat))) - (iup:button "Collapse" #:action (lambda (obj) - (debug:catch-and-dump - (lambda () - (let ((myname (iup:attribute obj "TITLE"))) - (if (equal? myname "Collapse") - (begin - (for-each (lambda (tname) - (hash-table-set! *collapsed* tname #t)) - (dboard:tabdat-item-test-names tabdat)) - (iup:attribute-set! obj "TITLE" "Expand")) - (begin - (for-each (lambda (tname) - (hash-table-delete! *collapsed* tname)) - (hash-table-keys *collapsed*)) - (iup:attribute-set! obj "TITLE" "Collapse")))) - (mark-for-update tabdat)) - "make-controls collapse button")))) - ) - (iup:vbox - ;; (iup:button "Sort -t" #:action (lambda (obj) - ;; (next-sort-option) - ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) - ;; (mark-for-update tabdat))) - - (let* ((hide #f) - (show #f) - (hide-empty #f) - (sel-color "180 100 100") - (nonsel-color "170 170 170") - (cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) - (sort-lb (iup:listbox #:expand "HORIZONTAL" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - (set! *tests-sort-reverse* index) - (mark-for-update tabdat)))) - (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) - (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd) - - (set! hide-empty (iup:button "HideEmpty" - #:expand "YES" - #:action (lambda (obj) - (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat))) - (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) - (mark-for-update tabdat)))) - (set! hide (iup:button "Hide" - #:expand "YES" - #:action (lambda (obj) - (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) - ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) - (iup:attribute-set! hide "BGCOLOR" sel-color) - (iup:attribute-set! show "BGCOLOR" nonsel-color) - (mark-for-update tabdat)))) - (set! show (iup:button "Show" - #:expand "YES" - #:action (lambda (obj) - (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat))) - (iup:attribute-set! show "BGCOLOR" sel-color) - (iup:attribute-set! hide "BGCOLOR" nonsel-color) - (mark-for-update tabdat)))) - (iup:attribute-set! hide "BGCOLOR" sel-color) - (iup:attribute-set! show "BGCOLOR" nonsel-color) - ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... - (iup:vbox - (iup:hbox hide show) - hide-empty sort-lb))) - ))) - (iup:frame - #:title "state/status filter" - (iup:vbox - (apply - iup:hbox - (map (lambda (status) - (iup:toggle (conc status " ") - #:action (lambda (obj val) - (mark-for-update tabdat) - (if (eq? val 1) - (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t) - (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status)) - (set-bg-on-filter commondat tabdat)))) - (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) - (apply - iup:hbox - (map (lambda (state) - (iup:toggle (conc state " ") - #:action (lambda (obj val) - (mark-for-update tabdat) - (if (eq? val 1) - (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) - (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) - (set-bg-on-filter commondat tabdat)))) - (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 (dboard:tabdat-tot-runs tabdat))) - (dboard:tabdat-start-run-offset-set! tabdat val) - (mark-for-update tabdat) - (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) - (iup:attribute-set! obj "MAX" (* maxruns 10)))) - #:expand "HORIZONTAL" - #:max (* 10 (length (dboard:tabdat-allruns tabdat))) - #:min 0 - #:step 0.01))) + (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat))) + (iup:hbox + (iup:vbox + (iup:frame + #:title "filter test and items" + (iup:hbox + (iup:vbox + (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" + #:expand "NO" + #:action (lambda (obj unk val) + (debug:catch-and-dump + (lambda () + (mark-for-update tabdat) + (update-search commondat tabdat "test-name" val)) + "make-controls"))) + (iup:hbox + (iup:button "Quit" #:action (lambda (obj) + ;; (if (dboard:tabdat-dblocal tabdat) (db:close-all (dboard:tabdat-dblocal tabdat))) + (exit)) + #:expand "NO" #:size "40x15") + (iup:button "Refresh" #:action (lambda (obj) + (mark-for-update tabdat)) + #:expand "NO" #:size "40x15") + (iup:button "Collapse" #:action (lambda (obj) + (debug:catch-and-dump + (lambda () + (let ((myname (iup:attribute obj "TITLE"))) + (if (equal? myname "Collapse") + (begin + (for-each (lambda (tname) + (hash-table-set! *collapsed* tname #t)) + (dboard:tabdat-item-test-names tabdat)) + (iup:attribute-set! obj "TITLE" "Expand")) + (begin + (for-each (lambda (tname) + (hash-table-delete! *collapsed* tname)) + (hash-table-keys *collapsed*)) + (iup:attribute-set! obj "TITLE" "Collapse")))) + (mark-for-update tabdat)) + "make-controls collapse button")) + #:expand "NO" #:size "40x15")) + ) + (iup:vbox + ;; (iup:button "Sort -t" #:action (lambda (obj) + ;; (next-sort-option) + ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) + ;; (mark-for-update tabdat))) + + (let* ((hide #f) + (show #f) + (hide-empty #f) + (sel-color "180 100 100") + (nonsel-color "170 170 170") + (cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) + (sort-lb (iup:listbox #:expand "NO" ;; "HORIZONTAL" + #:size "80x15" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + (set! *tests-sort-reverse* index) + (mark-for-update tabdat)))) + (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) + (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd) + + (set! hide-empty (iup:button "HideEmpty" + ;; #:expand HORIZONTAL" + #:expand "NO" #:size "80x15" + #:action (lambda (obj) + (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat))) + (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) + (mark-for-update tabdat)))) + (set! hide (iup:button "Hide" + #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" + #:action (lambda (obj) + (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) + ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) + (iup:attribute-set! hide "BGCOLOR" sel-color) + (iup:attribute-set! show "BGCOLOR" nonsel-color) + (mark-for-update tabdat)))) + (set! show (iup:button "Show" + #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" + #:action (lambda (obj) + (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat))) + (iup:attribute-set! show "BGCOLOR" sel-color) + (iup:attribute-set! hide "BGCOLOR" nonsel-color) + (mark-for-update tabdat)))) + (iup:attribute-set! hide "BGCOLOR" sel-color) + (iup:attribute-set! show "BGCOLOR" nonsel-color) + ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... + (iup:vbox + (iup:hbox hide show) + hide-empty sort-lb))) + ))) + (iup:frame + #:title "state/status filter" + (iup:vbox + (apply + iup:hbox + (map (lambda (status) + (iup:toggle (conc status " ") + #:fontsize btn-fontsz ;; "10" + #:expand "HORIZONTAL" + #:action (lambda (obj val) + (mark-for-update tabdat) + (if (eq? val 1) + (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t) + (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status)) + (set-bg-on-filter commondat tabdat)))) + (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) + (apply + iup:hbox + (map (lambda (state) + (iup:toggle (conc state " ") + #:fontsize btn-fontsz + #:expand "HORIZONTAL" + #:action (lambda (obj val) + (mark-for-update tabdat) + (if (eq? val 1) + (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) + (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) + (set-bg-on-filter commondat tabdat)))) + (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 (dboard:tabdat-tot-runs tabdat))) + (dboard:tabdat-start-run-offset-set! tabdat val) + (mark-for-update tabdat) + (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) + (iup:attribute-set! obj "MAX" (* maxruns 10)))) + #:expand "HORIZONTAL" + #:max (* 10 (length (dboard:tabdat-allruns tabdat))) + #:min 0 + #:step 0.01))) ;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1)))) ;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0)))) - )) + ))) (define (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt) (iup:menu (iup:menu-item "Run" @@ -2170,22 +1959,25 @@ (controls '()) (lftlst '()) (hdrlst '()) (bdylst '()) (result '()) - (i 0)) + (i 0) + (btn-height (dboard:tabdat-runs-btn-height runs-dat)) + (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) + (cell-width (dboard:tabdat-runs-cell-width runs-dat))) ;; controls (along bottom) (set! controls (dboard:make-controls commondat runs-dat)) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox (iup:label) ;; (iup:valuator) (apply iup:vbox (map (lambda (x) (let ((res (iup:hbox #:expand "HORIZONTAL" - (iup:label x #:size "x15" #:fontsize "10" #:expand "HORIZONTAL") - (iup:textbox #:size "x15" #:fontsize "10" #:value "%" #:expand "HORIZONTAL" + (iup:label x #:size (conc 40 btn-height) #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL") + (iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz #:value "%" #:expand "NO" ;; "HORIZONTAL" #:action (lambda (obj unk val) (mark-for-update runs-dat) (update-search commondat runs-dat x val)))))) (set! i (+ i 1)) res)) @@ -2197,11 +1989,11 @@ ;; now lftlst will be an hbox with the test keys and the test name labels (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (string->number (iup:attribute obj "VALUE"))) (oldmax (string->number (iup:attribute obj "MAX"))) - (newmax (* 10 (length *alltestnamelst*)))) + (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat))))) (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10)))) (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax) (if (< val 10) (iup:attribute-set! obj "MAX" newmax)) @@ -2210,24 +2002,24 @@ #:orientation "VERTICAL" #:min 0 #:step 0.01) (apply iup:vbox (reverse res))))))) (else - (let ((labl (iup:button "" + (let ((labl (iup:button "" ;; the testname labels #:flat "YES" #:alignment "ALEFT" ; #:image img1 ; #:impress img2 - #:size "x15" - #:expand "HORIZONTAL" - #:fontsize "10" + #:size (conc cell-width btn-height) + #:expand "NO" ;; "HORIZONTAL" + #:fontsize btn-fontsz #:action (lambda (obj) - (mark-for-update tabdat) - (toggle-hide testnum uidat))))) ;; (iup:attribute obj "TITLE")))) + (mark-for-update runs-dat) + (toggle-hide testnum (dboard:commondat-uidat commondat)))))) ;; (iup:attribute obj "TITLE")))) (vector-set! lftcol testnum labl) (loop (+ testnum 1)(cons labl res)))))) - ;; + ;; These are the headers for each row (let loop ((runnum 0) (keynum 0) (keyvec (make-vector nkeys)) (res '())) (cond ;; nb// no else for this approach. @@ -2235,11 +2027,11 @@ ((>= keynum nkeys) (vector-set! header runnum keyvec) (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) (loop (+ runnum 1) 0 (make-vector nkeys) '())) (else - (let ((labl (iup:label "" #:size "60x15" #:fontsize "10" #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL" + (let ((labl (iup:label "" #:size (conc cell-width btn-height) #:fontsize btn-fontsz #:expand "NO"))) ;; #:expand "HORIZONTAL" "60x15" (vector-set! keyvec keynum labl) (loop runnum (+ keynum 1) keyvec (cons labl res)))))) ;; By here the hdrlst contains a list of vboxes containing nkeys labels (let loop ((runnum 0) (testnum 0) @@ -2253,13 +2045,13 @@ (loop (+ runnum 1) 0 (make-vector ntests) '())) (else (let* ((button-key (mkstr runnum testnum)) (butn (iup:button "" ;; button-key - #:size "60x15" - #:expand "HORIZONTAL" - #:fontsize "10" + #:size (conc cell-width btn-height ) + #:expand "NO" + #:fontsize btn-fontsz #:button-cb (lambda (obj a pressed x y btn . rem) ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) (if (substring-index "3" btn) (if (eq? pressed 1) @@ -2300,26 +2092,36 @@ (iup:show (iup:dialog #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) #:menu (dcommon:main-menu) (let* ((runs-view (iup:vbox - (apply iup:hbox - (cons (apply iup:vbox lftlst) - (list - (iup:vbox - ;; the header - (apply iup:hbox (reverse hdrlst)) - (apply iup:hbox (reverse bdylst)))))) - ;; controls + (iup:split + #:orientation "VERTICAL" ;; "HORIZONTAL" + #:value 150 + (dboard:runs-tree-browser commondat runs-dat) + (apply iup:hbox + (cons (apply iup:vbox lftlst) + (list + (iup:vbox + ;; the header + (apply iup:hbox (reverse hdrlst)) + (apply iup:hbox (reverse bdylst))))))) + controls )) ;; (data (dboard:tabdat-init (make-d:data))) (tabs (iup:tabs #:tabchangepos-cb (lambda (obj curr prev) (debug:catch-and-dump (lambda () - (dboard:commondat-please-update-set! commondat #t) - (dboard:commondat-curr-tab-num-set! commondat curr)) + (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) + (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) + (dboard:tabdat-layout-update-ok-set! tabdat #f)) + (dboard:commondat-curr-tab-num-set! commondat curr) + (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) + (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) + (dboard:commondat-please-update-set! commondat #t) + (dboard:tabdat-layout-update-ok-set! tabdat #t))) "tabchangepos")) (dashboard:summary commondat stats-dat tab-num: 0) runs-view (dashboard:one-run commondat onerun-dat tab-num: 2) ;; (dashboard:new-view db data new-view-dat tab-num: 3) @@ -2343,22 +2145,19 @@ (dboard:common-set-tabdat! commondat 2 onerun-dat) (dboard:common-set-tabdat! commondat 3 runcontrols-dat) (dboard:common-set-tabdat! commondat 4 runtimes-dat) (iup:vbox tabs - controls)))) + ;; controls + )))) (vector keycol lftcol header runsvec))) (define (dboard:setup-num-rows tabdat) - (if (or (args:get-arg "-rows") - (get-environment-variable "DASHBOARDROWS" )) - (begin - (dboard:tabdat-num-tests-set! tabdat (string->number - (or (args:get-arg "-rows") - (get-environment-variable "DASHBOARDROWS")))) - (update-rundat tabdat "%" (dboard:tabdat-numruns tabdat) "%/%" '())) - (dboard:tabdat-num-tests-set! tabdat (min (max (update-rundat tabdat "%" (dboard:tabdat-numruns tabdat) "%/%" '()) 8) 20)))) + (dboard:tabdat-num-tests-set! tabdat (string->number + (or (args:get-arg "-rows") + (get-environment-variable "DASHBOARDROWS") + "15")))) (define *tim* (iup:timer)) (define *ord* #f) (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") @@ -2417,10 +2216,12 @@ ;; point inside line ;; (define-inline (dashboard:px-between px lx1 lx2) (and (< lx1 px)(> lx2 px))) +(define (dashboard:summary-tab-updater commondat tab-num) + (if dashboard:update-summary-tab (dashboard:update-summary-tab))) ;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing ;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows) ;; (define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f)) (let ((lastrow (if num-rows (+ rownum num-rows) rownum))) @@ -2621,13 +2422,13 @@ (mutex-unlock! mtx) (dboard:tabdat-view-changed-set! tabdat #f))))) ;; doesn't work. ;; -(define (gotoescape tabdat escape) - (or (dboard:tabdat-layout-update-ok tabdat) - (escape #t))) +;;(define (gotoescape tabdat escape) +;; (or (dboard:tabdat-layout-update-ok tabdat) +;; (escape #t))) (define (dboard:graph-db-open dbstr) (let* ((parts (string-split dbstr ":")) (dbpth (if (< (length parts) 2) ;; assume then a filename was provided dbstr @@ -2662,19 +2463,20 @@ (lambda (fieldname) ;; fields (let ((all-dat-qrystr (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " >= " tstart " AND " timef " <= " tend " ORDER BY " timef " ASC")) (zeroth-point (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1"))) (print "all-dat-qrystr: " all-dat-qrystr) (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr))))) - (sqlite3:fold-row - (lambda (res t var val) - (cons (vector t var val) res)) - '() db all-dat-qrystr)) + (reverse + (sqlite3:fold-row + (lambda (res t var val) + (cons (vector t var val) res)) + '() db all-dat-qrystr))) (let ((zeropt (handle-exceptions exn #f (sqlite3:first-row db all-dat-qrystr)))) - (if zeropt + (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above. (hash-table-set! res-ht fieldname (cons (apply vector tstart (cdr zeropt)) (hash-table-ref/default res-ht fieldname '()))))))) @@ -2684,50 +2486,104 @@ ;; graph data ;; tsc=timescale, tfn=function; time->x ;; (define (dboard:graph commondat tabdat tabnum llx lly ulx uly tstart tend tsc tfn compname cmargin) - (let* ((dwg (dboard:tabdat-drawing tabdat)) - (lib (vg:get/create-lib dwg "runslib")) - (cnv (dboard:tabdat-cnv tabdat)) - (dur (- tstart tend)) ;; time duration - (cmp (vg:get-component dwg "runslib" compname)) - (cfg (configf:get-section *configdat* "graph")) - (stdcolor (vg:rgb->number 20 30 40))) + (let* ((dwg (dboard:tabdat-drawing tabdat)) + (lib (vg:get/create-lib dwg "runslib")) + (cnv (dboard:tabdat-cnv tabdat)) + (dur (- tstart tend)) ;; time duration + (cmp (vg:get-component dwg "runslib" compname)) + (cfg (configf:get-section *configdat* "graph")) + (stdcolor (vg:rgb->number 120 130 140)) + (delta-y (- uly lly))) (vg:add-obj-to-comp cmp (vg:make-rect-obj llx lly ulx uly)) + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- (tfn tstart) 10)(- lly 10)(seconds->year-week/day-time tstart))) + (let*-values (((span timeunit time-blk first timesym) (common:find-start-mark-and-mark-delta tstart tend))) + (let loop ((mark first) + (count 0)) + (let* ((smark (tfn mark)) ;; scale the mark + (mark-delta (quotient (- mark tstart) time-blk)) ;; how far from first mark + (label (conc (* count span) timesym))) ;; was mark-delta + (if (> count 2) + (begin + (vg:add-obj-to-comp + cmp + (vg:make-rect-obj (- smark 1)(- lly 2)(+ smark 1) lly)) + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- smark 1)(- lly 10) label)))) + (if (< mark (- tend time-blk)) + (loop (+ mark time-blk)(+ count 1)))))) (for-each (lambda (cf) (let* ((alldat (dboard:graph-read-data (cadr cf) tstart tend))) (if alldat (for-each (lambda (fieldn) - (let* ((dat (hash-table-ref alldat fieldn )) + (let* ((dat (hash-table-ref alldat fieldn)) (vals (map (lambda (x)(vector-ref x 2)) dat))) (if (not (null? vals)) - (let* ((maxval (apply max vals)) - (minval (apply min vals)) - (yoff (- lly minval)) - (yscale (/ (- maxval minval)(- uly lly))) - (yfunc (lambda (y)(* (+ y yoff) yscale)))) - ;; (print (car cf) ": " (hash-table->alist - (for-each - (lambda (dpt) - (let* ((tval (vector-ref dpt 0)) - (yval (vector-ref dpt 2)) - (stval (tfn tval)) - (syval (yfunc yval))) - (vg:add-obj-to-comp - cmp - (vg:make-rect-obj (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) - fill-color: stdcolor)))) - dat))))) ;; for each data point in the series + (let* ((maxval (apply max vals)) + (minval (min 0 (apply min vals))) + (yoff (- minval lly)) ;; minval)) + (deltaval (- maxval minval)) + (yscale (/ delta-y (if (zero? deltaval) 1 deltaval))) + (yfunc (lambda (y)(+ lly (* yscale (- y minval)))))) ;; (lambda (y)(* (+ y yoff) yscale)))) + ;; (print (car cf) "; maxval: " maxval " minval: " minval " deltaval: " deltaval " yscale: " yscale) + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval))) + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval))) + (fold + (lambda (next prev) ;; #(time ? val) #(time ? val) + (if prev + (let* ((yval (vector-ref prev 2)) + (yval-next (vector-ref next 2)) + (last-tval (tfn (vector-ref prev 0))) + (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2)))) + (next-yval (yfunc yval-next)) + (curr-tval (tfn (vector-ref next 0)))) + (if (>= curr-tval last-tval) + (begin + (vg:add-obj-to-comp + cmp + ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) + (vg:make-line-obj last-tval last-yval curr-tval last-yval + line-color: stdcolor)) + (vg:add-obj-to-comp + cmp + ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) + (vg:make-line-obj curr-tval last-yval curr-tval next-yval + line-color: stdcolor))) + (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) + next) + ;; for init create vector tstart,0 + #f ;; (vector tstart minval minval) + dat) + + ;; (for-each + ;; (lambda (dpt) + ;; (let* ((tval (vector-ref dpt 0)) + ;; (yval (vector-ref dpt 2)) + ;; (stval (tfn tval)) + ;; (syval (yfunc yval))) + ;; (vg:add-obj-to-comp + ;; cmp + ;; (vg:make-rect-obj (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) + ;; fill-color: stdcolor)))) + ;; dat) + )))) ;; for each data point in the series (hash-table-keys alldat))))) cfg))) - ;; run times tab ;; (define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) ;; each test is an object in the run component ;; each run is a component @@ -2738,18 +2594,17 @@ (let* ((canvas-margin 10) (not-done-runs (dboard:tabdat-not-done-runs tabdat)) (mtx (dboard:tabdat-runs-mutex tabdat)) (drawing (dboard:tabdat-drawing tabdat)) (runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib - (layout-start (current-milliseconds)) (allruns (dboard:tabdat-allruns tabdat)) (num-runs (length allruns)) (cnv (dboard:tabdat-cnv tabdat)) (compact-layout (dboard:tabdat-compact-layout tabdat)) (row-height (if compact-layout 2 10)) (graph-height 120) - (run-to-run-margin 20)) + (run-to-run-margin 25)) (dboard:tabdat-layout-update-ok-set! tabdat #t) (if (canvas? cnv) (let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) ((originx originy) (canvas-origin cnv)) ((calc-y) (lambda (rownum) @@ -2806,20 +2661,20 @@ (num-tests (length hierdat)) (tot-tests (length testsdat)) (width (* timescale run-duration)) (graph-lly (calc-y (/ -50 row-height))) (graph-uly (- (calc-y 0) canvas-margin)) + (sec-per-50pt (/ 50 timescale)) ) - ;; (print "Testing. (maptime run-start=" run-start "): " (maptime run-start) " (maptime run-end=" run-end "): " (maptime run-end) " run-duration: " run-duration) - (print "run_duration: " (seconds->hr-min-sec run-duration)) + (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt) ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx) (mutex-lock! mtx) (vg:add-comp-to-lib runslib run-full-name runcomp) ;; Have to keep moving the instantiated box as it is anchored at the lower left ;; this should have worked for x in next statement? (maptime run-start) ;; add 60 to make room for the graph - (vg:instantiate drawing "runslib" run-full-name run-full-name 0 (- (calc-y curr-run-start-row) (+ graph-height run-to-run-margin))) + (vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin))) (mutex-unlock! mtx) ;; (set! run-start-row (+ max-row 2)) ;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1)) ;; get tests in list sorted by event time ascending (let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!) @@ -2847,20 +2702,20 @@ (if (dashboard:row-collision rowhash rownum event-time end-time) (loop (+ rownum 1)) (let* ((title (if iterated (if compact-layout #f item-path) test-name)) (lly (calc-y rownum)) ;; (- sizey (* rownum row-height))) (uly (+ lly row-height)) - (use-end (if (< (- end-time event-time) 3)(+ event-time 3) end-time)) ;; if short grow it a little to give the user something to click on + (use-end (if (< (- end-time event-time) 2)(+ event-time 2) end-time)) ;; if short grow it a little to give the user something to click on (obj (vg:make-rect-obj event-time lly use-end uly fill-color: (vg:iup-color->number (car name-color)) text: title font: "Helvetica -10")) - (bar-end (+ 5 (max use-end - (+ 3 event-time - (if compact-layout - 0 - (* (string-length title) 10))))))) ;; 8 pixels per letter + (bar-end (max use-end + (+ event-time + (if compact-layout + 1 + (+ 7 (* (string-length title) 10))))))) ;; 8 pixels per letter ;; (if iterated ;; (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items)) ;; (if (not first-rownum) ;; (begin ;; (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items) @@ -2893,18 +2748,22 @@ text: (db:test-get-testname (hash-table-ref tests-ht (car test-ids))) line-color: (vg:rgb->number 0 0 255 a: 128) font: "Helvetica -10")) ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat)) (dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw - (if (gotoescape tabdat escape) ;; (dboard:tabdat-layout-update-ok tabdat) - (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs)))))) + (if (dboard:tabdat-layout-update-ok tabdat) + (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs) + (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) + ))))) ;; If it is an iterated test put box around it now. (if (not (null? tests-tal)) (if #f ;; (> (- (current-seconds) update-start-time) 5) (print "drawing runs taking too long") - (if (gotoescape tabdat escape) ;; (dboard:tabdat-layout-update-ok tabdat) - (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1))))))) + (if (dboard:tabdat-layout-update-ok tabdat) + (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1)) + (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) + ))))) ;; placeholder box (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1)) ;; (let ((y (calc-y (dboard:tabdat-max-row tabdat)))) ;; (- sizey (* (dboard:tabdat-max-row tabdat) row-height)))) ;; (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y))) ;; instantiate the component @@ -2921,16 +2780,17 @@ ;; this is the box around the run (mutex-lock! mtx) (vg:add-obj-to-comp runcomp outln) (mutex-unlock! mtx) ;; this is where we have enough info to place the graph - (dboard:graph commondat tabdat tab-num -5 (+ uly 3) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin) + (dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin) (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height))) ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat)) )) ;; end of the run handling loop - (if (gotoescape tabdat escape) ;; (dboard:tabdat-layout-update-ok tabdat) + (if (not (dboard:tabdat-layout-update-ok tabdat)) + (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) (let ((newdoneruns (cons rundat doneruns))) (if (null? runtal) (begin (dboard:rundat-data-changed-set! rundat #f) (dboard:tabdat-not-done-runs-set! tabdat '()) @@ -2940,30 +2800,42 @@ (print "drawing runs taking too long.... have " (length runtal) " remaining") ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here! ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t)) (dboard:tabdat-not-done-runs-set! tabdat runtal)) (begin - (if (gotoescape tabdat escape) ;; (dboard:tabdat-layout-update-ok tabdat) - (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)))))))))) ;; new-run-start-row - ) - (print "Layout end: " (current-milliseconds) " delta: " (- (current-milliseconds) layout-start)))) + (if (dboard:tabdat-layout-update-ok tabdat) + (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns) + (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) + ))))))))) ;; new-run-start-row + ))) (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater")))) (define (dashboard:runs-tab-updater commondat tab-num) (debug:catch-and-dump (lambda () - (let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) - (update-rundat tabdat (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") (dboard:tabdat-numruns tabdat) + (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) + (dbkeys (dboard:tabdat-dbkeys tabdat))) + (update-rundat tabdat + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") + (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 '())) - (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)) + (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) + ;; (print "dbkeys: " dbkeys) + (let ((fres (if (dboard:tabdat-target tabdat) + (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%")))) + (map (lambda (k v)(list k v)) dbkeys ptparts)) + (let ((res '())) + ;; (print "target: " (dboard:tabdat-target tabdat)) + (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)))))) + dbkeys) + res)))) + ;; (debug:print 0 *default-log-port* "fres: " fres) + fres))) (let ((uidat (dboard:commondat-uidat commondat))) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) "dashboard:runs-tab-updater")) @@ -3018,11 +2890,10 @@ ;; (lambda () ;; (dashboard:summary-tab-updater commondat 0)) ;; tab-num: 0) ;; runs tab (dboard:commondat-curr-tab-num-set! commondat 0) - ;; this next call is working and doing what it should (dboard:commondat-add-updater commondat (lambda () (dashboard:runs-tab-updater commondat 1)) tab-num: 1) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1627,11 +1627,12 @@ (set! *db-keys* res) res))) ;; look up values in a header/data structure (define (db:get-value-by-header row header field) - (if (null? header) #f + (if (or (null? header) (not row)) + #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) (vector-ref row n) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -67,15 +67,15 @@ (hash-table-set! *cachedata* "runid-to-col" (make-hash-table)) (hash-table-set! *cachedata* "testname-to-row" (make-hash-table)) ;; modify a cell if the data is changed, return #t or-ed with previous if modified, #f elsewise ;; -(define (dcommon:modify-if-different mtrx cell-name new-val prev-changed) +(define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed) (let ((curr-val (iup:attribute mtrx cell-name))) (if (not (equal? curr-val new-val)) (begin - (iup:attribute-set! mtrx cell-name new-val) + (iup:attribute-set! mtrx cell-name col-name) #t) ;; need a re-draw prev-changed))) ;; TO-DO @@ -144,11 +144,11 @@ (run-name (db:get-value-by-header run-record header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name)))) (hash-table-set! (dboard:tabdat-run-keys data) run-id run-path) ;; modify cell - but only if changed - (set! changed (dcommon:modify-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed)) + (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed)) (hash-table-set! runid-to-col run-id (list colnum run-record)) ;; Here we update the tests treebox and tree keys (tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) (set! colnum (+ colnum 1)))) @@ -203,11 +203,11 @@ 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 *default-log-port* "node-num: " node-num ", color: " color) - (set! changed (dcommon:modify-if-different + (set! changed (dcommon:modifiy-if-different tb (conc "COLOR" node-num) color changed)) ;; (iup:attribute-set! tb (conc "COLOR" node-num) color) @@ -218,21 +218,21 @@ (set! rownum (if (null? rownums) 1 (+ 1 (apply max rownums)))) (hash-table-set! testname-to-row fullname rownum) ;; create the label - (set! changed (dcommon:modify-if-different + (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) (conc rownum ":" 0) dispname changed)) ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) ;; (conc rownum ":" 0) dispname) )) ;; set the cell text and color ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status) - (set! changed (dcommon:modify-if-different + (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) (conc rownum ":" colnum) (if (member state '("ARCHIVED" "COMPLETED")) status state) @@ -240,11 +240,11 @@ ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) ;; (conc rownum ":" colnum) ;; (if (member state '("ARCHIVED" "COMPLETED")) ;; status ;; state)) - (set! changed (dcommon:modify-if-different + (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) (conc "BGCOLOR" rownum ":" colnum) (car (gutils:get-color-for-state-status state status)) changed)) ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) @@ -272,15 +272,15 @@ (if (null? tests-dat) '() (let loop ((hed (car tests-dat)) (tal (cdr tests-dat)) (res '())) - (let* ((test-id (vector-ref hed 0)) ;; look at the tests-dat spec for locations - (test-name (vector-ref hed 1)) - (item-path (vector-ref hed 2)) - (state (vector-ref hed 3)) - (status (vector-ref hed 4)) + (let* ((test-id (db:test-get-id hed)) ;; look at the tests-dat spec for locations + (test-name (db:test-get-testname hed)) + (item-path (db:test-get-item-path hed)) + (state (db:test-get-status hed)) + (status (db:test-get-status hed)) (newitem (list test-name item-path (list test-id state status)))) (if (null? tal) (reverse (cons newitem res)) (loop (car tal)(cdr tal)(cons newitem res))))))) Index: docs/api.html ================================================================== --- docs/api.html +++ docs/api.html @@ -822,24 +822,171 @@

{ "error" : "Error message" }

1.2. Get List of Runs

-

URL: <base>/get_runs

+

URL: <base>/runs

+

Method: GET

+

Filter Params: target, testpatt, offset, limit

+

Response:

+
+
+

[ + { + "run_id" : "1", + "name" : "runname1", + "target" : "target1", + "tests" : + [ + "test": + [ + {"id": 1, "name":test1, "item_path": "", "shortdir": "/temp/foo/bar/target1/runname1/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS#"} + {"id": 2, "name":test2, "item_path": "", "shortdir": "/temp/foo/bar/target1/runname1/test2", "final_logf": "megatest-rollup-test2.html", "status": "PASS"} + {"id": 3, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target1/runname1/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} + ] + ] + }, + { + "run_id" : "2", + "name" : "runname2", + "target" : "target2", + "tests" : + [ + "test: + [ + {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} + {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} + {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} + ] + ] + } +]

+
+
+
+

1.3. Trigger a new Run

+

URL: <base>/runs

+

Method: POST

+

Request Params:

+
+
+

{"target": "target_value", "runname" : "runname", "test_pattern": "optional test pattern"}

+
+

Response:

+

If Error

+
+
+

{ "error" : "Error message" }

+
+

If Success returns the results of the run

+
+
+

[ + { + "run_id" : "2", + "name" : "runname2", + "target" : "target2", + "tests" : + [ + "test: + [ + {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} + {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} + {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} + ] + ] + } +]

+
+
+
+

1.4. Get perticular Run

+

URL: <base>/runs/:id

+

Method: GET

+

Filter Params: testpatt

+

Response:

+
+
+

[ + { + "run_id" : "2", + "name" : "runname2", + "target" : "target2", + "tests" : + [ + "test": + [ + {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} + {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} + {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} + ] + ] + } +]

+
+
+
+

1.5. Re-execute a run

+

URL: <base>/runs/:id

+

Method: PUT/PATCH

+

Request Params: {"testpatt" : "pattern"}

+

Response:

+
+
+

[ + { + "run_id" : "2", + "name" : "runname2", + "target" : "target2", + "tests" : + [ + "test": + [ + {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} + {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} + {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} + ] + ] + } +]

+
+
+
+

1.6. Get List of tests within a run

+

URL: <base>/runs/:id/tests

Method: GET

-

Params: target, testpatt, offset, limit

+

Response:

+
+
+

[ + "tests" : + [ + {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} + {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} + {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} + ] +]

+
+
+
+

1.7. Re-execute a test within a run

+

URL: <base>/runs/:id/tests/:id

+

Method: PUT/PATCH

+

Response:

+
+
+

{"id": "4", "name":"test1", "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}

+
+
+
+

1.8. Get perticular test that belongs to a Runs

+

URL: <base>/runs/:id/tests/:id

+

Method: GET

Response:

-

{ "us" : "United States of America" }

-
-

Another example ….

-
-
-

{ "places": [ [ "place_name", "place_description ], … ], - "friends": [ [ "short_name", "username", "location", uid, frequency ], … ], - "iousum": [ [ "nick:location", est_iou ], …] }

+

{"id": "4", "name":"test1", "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}

@@ -863,10 +1010,10 @@
Index: docs/api.txt ================================================================== --- docs/api.txt +++ docs/api.txt @@ -34,29 +34,205 @@ =================== Get List of Runs ~~~~~~~~~~~~~~~~ -URL: /get_runs +URL: /runs Method: GET -Params: target, testpatt, offset, limit +Filter Params: target, testpatt, offset, limit Response: -================= -{ "[blue]#us#" : "[red]#United States of America#" } -================= + +================== +[ + { + "[red]#run_id#" : "1", + "[red]#name#" : "runname1", + "[red]#target#" : "target1", + "[red]#tests#" : + [ + "[green]#test#": + [ + {"[blue]#id#": 1, "[blue]#name#":test1, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target1/runname1/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS#"} + {"[blue]#id#": 2, "[blue]#name#":test2, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target1/runname1/test2", "[blue]#final_logf#": "megatest-rollup-test2.html", "[blue]#status#": "PASS"} + {"[blue]#id#": 3, "[blue]#name#":test3, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target1/runname1/test3", "[blue]#final_logf#": "megatest-rollup-test3.html", "[blue]#status#": "PASS"} + ] + ] + }, + { + "[red]#run_id#" : "2", + "[red]#name#" : "runname2", + "[red]#target#" : "target2", + "[red]#tests#" : + [ + "[green]#test#: + [ + {"[blue]#id#": 4, "[blue]#name#":[blue]#test1#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"} + {"[blue]#id#": 5, "[blue]#name#":[blue]#test2#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test2", "[blue]#final_logf#": "megatest-rollup-test2.html", "[blue]#status#": "FAIL"} + {"[blue]#id#": 6, "[blue]#name#":test3, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test3", "[blue]#final_logf#": "megatest-rollup-test3.html", "[blue]#status#": "PASS"} + ] + ] + } +] +================== + + +Trigger a new Run +~~~~~~~~~~~~~~~~~~ + +URL: /runs + +Method: POST + +Request Params: +================== +{"[blue]#target#": "target_value", "[blue]#runname#" : "runname", "[blue]#test_pattern#": "optional test pattern"} +================== + +Response: + +If Error +=================== +{ "[blue]#error#" : "[red]#Error message#" } +=================== + +If Success returns the results of the run + +================== +[ + { + "[red]#run_id#" : "2", + "[red]#name#" : "runname2", + "[red]#target#" : "target2", + "[red]#tests#" : + [ + "[green]#test#: + [ + {"[blue]#id#": 4, "[blue]#name#":[blue]#test1#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"} + {"[blue]#id#": 5, "[blue]#name#":[blue]#test2#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test2", "[blue]#final_logf#": "megatest-rollup-test2.html", "[blue]#status#": "FAIL"} + {"[blue]#id#": 6, "[blue]#name#":test3, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test3", "[blue]#final_logf#": "megatest-rollup-test3.html", "[blue]#status#": "PASS"} + ] + ] + } +] +================== + + + +Get perticular Run +~~~~~~~~~~~~~~~~~~~ + +URL: /runs/:id + +Method: GET + +Filter Params: testpatt + +Response: + +================== +[ + { + "[red]#run_id#" : "2", + "[red]#name#" : "runname2", + "[red]#target#" : "target2", + "[red]#tests#" : + [ + "[green]#test#": + [ + {"[blue]#id#": 4, "[blue]#name#":[blue]#test1#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"} + {"[blue]#id#": 5, "[blue]#name#":[blue]#test2#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test2", "[blue]#final_logf#": "megatest-rollup-test2.html", "[blue]#status#": "FAIL"} + {"[blue]#id#": 6, "[blue]#name#":test3, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test3", "[blue]#final_logf#": "megatest-rollup-test3.html", "[blue]#status#": "PASS"} + ] + ] + } +] +================== + + +Re-execute a run +~~~~~~~~~~~~~~~~~ + +URL: /runs/:id + +Method: PUT/PATCH + +Request Params: {"testpatt" : "pattern"} + +Response: + +================== +[ + { + "[red]#run_id#" : "2", + "[red]#name#" : "runname2", + "[red]#target#" : "target2", + "[red]#tests#" : + [ + "[green]#test#": + [ + {"[blue]#id#": 4, "[blue]#name#":[blue]#test1#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"} + {"[blue]#id#": 5, "[blue]#name#":[blue]#test2#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test2", "[blue]#final_logf#": "megatest-rollup-test2.html", "[blue]#status#": "FAIL"} + {"[blue]#id#": 6, "[blue]#name#":test3, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test3", "[blue]#final_logf#": "megatest-rollup-test3.html", "[blue]#status#": "PASS"} + ] + ] + } +] +================== + + + +Get List of tests within a run +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +URL: /runs/:id/tests + +Method: GET + +Response: +================== +[ + "[red]#tests#" : + [ + {"[blue]#id#": 4, "[blue]#name#":[blue]#test1#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"} + {"[blue]#id#": 5, "[blue]#name#":[blue]#test2#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test2", "[blue]#final_logf#": "megatest-rollup-test2.html", "[blue]#status#": "FAIL"} + {"[blue]#id#": 6, "[blue]#name#":test3, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test3", "[blue]#final_logf#": "megatest-rollup-test3.html", "[blue]#status#": "PASS"} + ] +] +================== + + +Re-execute a test within a run +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +URL: /runs/:id/tests/:id + +Method: PUT/PATCH + +Response: + +================== +{"[blue]#id#": "4", "[blue]#name#":"test1", "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"} +================== + + +Get perticular test that belongs to a Runs +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +URL: /runs/:id/tests/:id + +Method: GET -Another example .... +Response: ================== -{ "[blue]#places#": [ [ "[red]#place_name#", "[red]#place_description# ], ... ], - "[blue]#friends#": [ [ "[red]#short_name#", "[red]#username#", "[red]#location#", [red]#uid#, [red]#frequency# ], ... ], - "[blue]#iousum#": [ [ "[red]#nick:location#", [red]#est_iou# ], ...] } +{"[blue]#id#": "4", "[blue]#name#":"test1", "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"} ================== + Notes ----- Index: docs/megatest-about.svg ================================================================== --- docs/megatest-about.svg +++ docs/megatest-about.svg @@ -1,492 +1,3121 @@ - - - - - - - - - - - - - - - - image/svg+xml - - - - - - - - Megatest - Simple - but not TOO simple! - - Automation - Quality Assurance - Regression Testing - System Administration - - - - - - Write one task or test and iterateDistribute tasks over one or many hostsOrganize runs by any variables you wish - release - architecture - unit or partitionTasks or tests may depend on othersEach task or test runs in clean areaAdd disk space or partitions as neededRigorous results; error, pass, warn etc.Crontab friendly runs (skip if running)Easy debugging - easy to recreate environment for task - annotated HTML logs help find issuesSimplify scripts - eliminate for-each or while loops - parallel running handled by tool - - FAIL - - PASS - - WARN - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -150,11 +150,31 @@ (if (null? dat) #f dat)) #f)) -(define (env:print added removed changed) +(define (env:inc-path path) + (print "PATH " + (conc "#{scheme (env:min-path \"" path "\" \"#{getenv PATH}\")}"))) +;; (conc +;; "#{scheme (string-intersperse " +;; "(delete-duplicates " +;; "(append (string-split \"" path "\" \":\") " +;; "(string-split \"#{getenv PATH}\" \":\")))" +;; " \":\")}"))) + +(define (env:min-path path1 path2) + (string-intersperse + (delete-duplicates + (append + (string-split path1 ":") + (string-split path2 ":"))) + ":")) + +;; inc path will set a PATH that is incrementally modified when read - config mode only +;; +(define (env:print added removed changed #!key (inc-path #t)) (let ((a (env:lazy-hash-table->alist added)) (r (env:lazy-hash-table->alist removed)) (c (env:lazy-hash-table->alist changed))) (case (if (args:get-arg "-dumpmode") (string->symbol (args:get-arg "-dumpmode")) @@ -193,19 +213,31 @@ (hash-table->alist changed))))) ((config ini) (if a (begin (print "# Added vars") - (map (lambda (dat)(print (car dat) " " (cdr dat))) + (map (lambda (dat) + (let ((var (car dat)) + (val (cdr dat))) + (if (and inc-path + (equal? var "PATH")) + (env:inc-path val) + (print var " " val)))) (hash-table->alist added)))) (if r (begin (print "# Removed vars") (map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}")) (hash-table->alist removed)))) (if c (begin (print "# Changed vars") - (map (lambda (dat)(print (car dat) " " (cdr dat))) + (map (lambda (dat) + (let ((var (car dat)) + (val (cdr dat))) + (if (and inc-path + (equal? var "PATH")) + (env:inc-path val) + (print var " " val)))) (hash-table->alist changed))))) (else (debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]"))))) Index: gen-data-for-graph.scm ================================================================== --- gen-data-for-graph.scm +++ gen-data-for-graph.scm @@ -21,11 +21,11 @@ (if (> sec lastsec) (exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)") (+ thetime sec) ;; (* sec 60)) "stuff" (if (even? thehour) - (random 100) + (random 1000) (random 6)))) (if (< count 20) (loop (max sec lastsec)(random 60)(+ count 1)))))))) (close-database db) Index: run-eff.sql ================================================================== --- run-eff.sql +++ run-eff.sql @@ -8,7 +8,7 @@ (max(event_time+run_duration)-min(event_time))/max(run_duration) AS ratio, testname from tests where item_path != '' AND state != 'DELETED' group by run_id order by ratio DESC) AS dat join runs on dat.run_id=runs.id -WHERE ratio > 1 +WHERE ratio > 0 AND runs.state != 'deleted'; Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -9,11 +9,11 @@ ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) - posix-extras directory-utils pathname-expand defstruct format) + posix-extras directory-utils pathname-expand typed-records format) (import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) @@ -31,16 +31,28 @@ (include "run_records.scm") (include "test_records.scm") ;; (include "debugger.scm") -(define (runs:test-get-full-path test) - (let* ((testname (db:test-get-testname test)) - (itempath (db:test-get-item-path test))) - (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) +;; use this struct to facilitate refactoring +;; +(defstruct runs:dat + reglen regfull + runname max-concurrent-jobs run-id + test-patts required-tests test-registry + registry-mutex flags keyvals run-info all-tests-registry + can-run-more-tests + ((can-run-more-tests-count 0) : fixnum)) +(defstruct runs:testdat + hed tal reg reruns test-record + test-name item-path jobgroup + waitons testmode newtal itemmaps prereqs-not-met) + +;; set up needed environment variables given a run-id and optionally a target, itempath etc. +;; (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) (let* ((target (or intarget (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) @@ -98,13 +110,20 @@ ;; Every time can-run-more-tests is called increment the delay ;; ;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine ;; (define *last-num-running-tests* 0) -(define *runs:can-run-more-tests-count* 0) -(define (runs:shrink-can-run-more-tests-count) - (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2))) +;; (define *runs:can-run-more-tests-count* 0) +(define (runs:shrink-can-run-more-tests-count runsdat) + (runs:dat-can-run-more-tests-count-set! runsdat 0)) + +(define (runs:inc-can-run-more-tests-count runsdat) + (runs:dat-can-run-more-tests-count-set! + runsdat + (+ (runs:dat-can-run-more-tests-count runsdat) 1))) + +;; (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2))) ;; Temporary globals. Move these into the logic or into common ;; (define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run (define (runs:inc-cant-run-tests testname) @@ -114,22 +133,32 @@ (define (runs:can-keep-running? testname n) (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n)) (define *runs:denoise* (make-hash-table)) ;; key => last-time-ran +;; mechanism to limit printing info to the screen that is repetitive. +;; +;; Example: +;; (if (runs:lownoise "waiting on tasks" 60) +;; (debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ...")) +;; (define (runs:lownoise key waitval) (let ((lasttime (hash-table-ref/default *runs:denoise* key 0)) (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) -(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) +(define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) + ;; Take advantage of a good place to exit if running the one-pass methodology + (if (and (> (runs:dat-can-run-more-tests-count runsdat) 20) + (args:get-arg "-one-pass")) + (exit 0)) (thread-sleep! (cond - ((> *runs:can-run-more-tests-count* 20) + ((> (runs:dat-can-run-more-tests-count runsdat) 20) (if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ...")) 2);; obviously haven't had any work to do for a while (else 0))) (let* ((num-running (rmt:get-count-tests-running run-id)) (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) @@ -136,11 +165,11 @@ (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) (if (string? jobg-count) (string->number jobg-count) jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) - (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) + (runs:inc-can-run-more-tests-count runsdat)) ;; (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) (begin (debug:print 2 *default-log-port* "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (set! *last-num-running-tests* num-running))) (if (not (eq? 0 *globalexitstatus*)) @@ -434,19 +463,10 @@ (car reg) (if (null? tal) ;; tal is used up, pop from reg (car reg) (car tal)))) -;; (cond -;; ((and regfull (null? reg)(not (null? tal))) (car tal)) -;; ((and regfull (not (null? reg))) (car reg)) -;; ((and (not regfull)(null? tal)(not (null? reg))) (car reg)) -;; ((and (not regfull)(not (null? tal))) (car tal)) -;; (else -;; (debug:print-error 0 *default-log-port* "runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull) -;; #f))) - (define (runs:queue-next-tal tal reg n regfull) (if regfull tal (if (null? tal) ;; must transfer from reg (cdr reg) @@ -652,20 +672,52 @@ t) (else (conc t)))) inlst))) -(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps) - (let* ((run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running - (have-resources (car run-limits-info)) - (num-running (list-ref run-limits-info 1)) - (num-running-in-jobgroup (list-ref run-limits-info 2)) - (max-concurrent-jobs (list-ref run-limits-info 3)) - (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + +;; hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps) +(define (runs:process-expanded-tests runsdat testdat) + ;; unroll the contents of runsdat and testdat (due to ongoing refactoring). + (let* ((hed (runs:testdat-hed testdat)) + (tal (runs:testdat-tal testdat)) + (reg (runs:testdat-reg testdat)) + (reruns (runs:testdat-reruns testdat)) + (test-name (runs:testdat-test-name testdat)) + (item-path (runs:testdat-item-path testdat)) + (jobgroup (runs:testdat-jobgroup testdat)) + (waitons (runs:testdat-waitons testdat)) + (item-path (runs:testdat-item-path testdat)) + (testmode (runs:testdat-testmode testdat)) + (newtal (runs:testdat-newtal testdat)) + (itemmaps (runs:testdat-itemmaps testdat)) + (test-record (runs:testdat-test-record testdat)) + (prereqs-not-met (runs:testdat-prereqs-not-met testdat)) + + (reglen (runs:dat-reglen runsdat)) + (regfull (runs:dat-regfull runsdat)) + (runname (runs:dat-runname runsdat)) + (max-concurrent-jobs (runs:dat-max-concurrent-jobs runsdat)) + (run-id (runs:dat-run-id runsdat)) + (test-patts (runs:dat-test-patts runsdat)) + (required-tests (runs:dat-required-tests runsdat)) + (test-registry (runs:dat-test-registry runsdat)) + (registry-mutex (runs:dat-registry-mutex runsdat)) + (flags (runs:dat-flags runsdat)) + (keyvals (runs:dat-keyvals runsdat)) + (run-info (runs:dat-run-info runsdat)) + (all-tests-registry (runs:dat-all-tests-registry runsdat)) + (run-limits-info (runs:dat-can-run-more-tests runsdat)) + ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + (have-resources (car run-limits-info)) + (num-running (list-ref run-limits-info 1)) + (num-running-in-jobgroup(list-ref run-limits-info 2)) + (max-concurrent-jobs (list-ref run-limits-info 3)) + (job-group-limit (list-ref run-limits-info 4)) + ;; (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) - (fails (if (list? prereqs-not-met) + (fails (if (list? prereqs-not-met) (runs:calc-fails prereqs-not-met) (begin (debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met) '()))) (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! @@ -728,11 +780,11 @@ (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) (begin (rmt:register-test run-id test-name "") (if (rmt:get-test-id run-id test-name "") (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) (if (and (null? tal)(null? reg)) (list hed tal (append reg (list hed)) reruns) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) ;; NB// Here we are building reg as we register tests @@ -781,11 +833,11 @@ (if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified (common:wait-for-cpuload maxload numcpus waitdelay)) (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) (runs:incremental-print-results run-id) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) @@ -818,11 +870,11 @@ (begin (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path " from the launch list as it has prerequistes that are FAIL") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) ;; This next is for the items (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed) (list (runs:queue-next-hed tal reg reglen regfull) @@ -847,11 +899,11 @@ (+ nth-try 1) 0)) (if (runs:lownoise (conc "not removing test " hed) 60) (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (list hed tal reg reruns) ;; (list (car newtal)(cdr newtal) reg reruns) ;; (hash-table-set! test-registry hed 'removed) (list (runs:queue-next-hed newtal reg reglen regfull) (runs:queue-next-tal newtal reg reglen regfull) @@ -990,11 +1042,11 @@ ;; Do mark-and-find clean up of db before starting runing of quue ;; ;; (rmt:find-and-mark-incomplete) - (let ((run-info (rmt:get-run-info run-id)) + (let* ((run-info (rmt:get-run-info run-id)) (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) (registry-mutex (make-mutex)) (num-retries 0) @@ -1004,11 +1056,40 @@ (string->number mcj) 1))) ;; length of the register queue ahead (reglen (if (number? reglen-in) reglen-in 1)) (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle (last-time-some-running (current-seconds)) - (tdbdat (tasks:open-db))) + (tdbdat (tasks:open-db)) + (runsdat (make-runs:dat + ;; hed: hed + ;; tal: tal + ;; reg: reg + ;; reruns: reruns + reglen: reglen + regfull: #f ;; regfull + ;; test-record: test-record + runname: runname + ;; test-name: test-name + ;; item-path: item-path + ;; jobgroup: jobgroup + max-concurrent-jobs: max-concurrent-jobs + run-id: run-id + ;; waitons: waitons + ;; testmode: testmode + test-patts: test-patts + required-tests: required-tests + test-registry: test-registry + registry-mutex: registry-mutex + flags: flags + keyvals: keyvals + run-info: run-info + ;; newtal: newtal + all-tests-registry: all-tests-registry + ;; itemmaps: itemmaps + ;; prereqs-not-met: (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps) + ;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running + ))) ;; Initialize the test-registery hash with tests that already have a record ;; convert state to symbol and use that as the hash value (for-each (lambda (trec) (let ((id (db:test-get-id trec)) @@ -1052,12 +1133,27 @@ (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat)) (tfullname (db:test-make-full-name test-name item-path)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen)) - (num-running (rmt:get-count-tests-running-for-run-id run-id))) - + (num-running (rmt:get-count-tests-running-for-run-id run-id)) + (testdat (make-runs:testdat + hed: hed + tal: tal + reg: reg + reruns: reruns + test-record: test-record + test-name: test-name + item-path: item-path + jobgroup: jobgroup + waitons: waitons + testmode: testmode + newtal: newtal + itemmaps: itemmaps + ;; prereqs-not-met: prereqs-not-met + ))) + (runs:dat-regfull-set! runsdat regfull) ;; every couple minutes verify the server is there for this run (if (and (common:low-noise-print 60 "try start server" run-id) (tasks:need-server run-id)) (tasks:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood @@ -1103,21 +1199,10 @@ "\n reruns: " reruns "\n regfull: " regfull "\n reglen: " reglen "\n length reg: " (length reg) "\n reg: " reg) - - ;; lets use the debugger eh? -;; (debugger-start start: 7) -;; (debugger-trace-var "runs:run-tests-queue" "") -;; (debugger-trace-var "hed" hed) -;; (debugger-trace-var "tal" tal) -;; (debugger-trace-var "items" items) -;; (debugger-trace-var "item-path" item-path) -;; (debugger-trace-var "waitons" waitons) -;; (debugger-pauser) - ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member test-name waitons) (begin @@ -1147,12 +1232,14 @@ ((not items) (debug:print-info 4 *default-log-port* "OUTER COND: (not items)") (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) (not (null? tal))) (loop (car tal)(cdr tal) reg reruns)) - (let ((loop-list (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps))) - (if loop-list (apply loop loop-list)))) + (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + (let ((loop-list (runs:process-expanded-tests runsdat testdat))) + (if loop-list (apply loop loop-list)))) ;; items processed into a list but not came in as a list been processed ;; ((and (list? items) ;; thus we know our items are already calculated (not itemdat)) ;; and not yet expanded into the list of things to be done @@ -1199,11 +1286,11 @@ ;; if items is a proc then need to run items:get-items-from-config, get the list and loop ;; - but only do that if resources exist to kick off the job ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs))) + (let ((can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))) (if (and (list? can-run-more) (car can-run-more)) (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps))) (if loop-list (apply loop loop-list))) @@ -1304,10 +1391,11 @@ (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step +;; (define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) ;; All these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record)) Index: vg-test.scm ================================================================== --- vg-test.scm +++ vg-test.scm @@ -7,17 +7,18 @@ ;; (if (> (length (argv)) 1) ;; (string->number (cadr (argv))) ;; 1000)) (use trace) - (trace - ;; vg:draw-rect - ;; vg:grow-rect - vg:get-extents-for-objs - vg:components-get-extents - vg:instances-get-extents - vg:get-extents-for-two-rects) + ;; (trace + ;; ;; vg:draw-rect + ;; ;; vg:grow-rect + ;; vg:get-extents-for-objs + ;; vg:components-get-extents + ;; vg:instances-get-extents + ;; vg:get-extents-for-two-rects + ;; canvas-line!) (define d1 (vg:drawing-new)) (define l1 (vg:lib-new)) (define c1 (vg:comp-new)) (define c2 (vg:comp-new)) @@ -36,10 +37,12 @@ (let loop ((i 0)) (vg:add-obj-to-comp c1 (vg:make-rect-obj 0 0 100 100)) (if (< i numtorun)(loop (+ i 1)))) (print "Run time: " (- (current-seconds) start))) +(vg:add-obj-to-comp c1 (vg:make-line-obj 0 0 100 100)) + ;; add the c1 component to lib l1 with name firstcomp (vg:add-comp-to-lib l1 "firstcomp" c1) (vg:add-comp-to-lib l1 "secondcomp" c2) ;; add the l1 lib to drawing with name firstlib @@ -46,10 +49,11 @@ (vg:add-lib d1 "firstlib" l1) ;; instantiate firstlib/firstcomp as inst1 in drawing d1 at 0,0 (vg:instantiate d1 "firstlib" "firstcomp" "inst1" 0 0) (vg:instantiate d1 "firstlib" "firstcomp" "inst2" 200 200) + ;; (vg:drawing-scalex-set! d1 1.1) ;; (vg:drawing-scaley-set! d1 0.5) ;; (define xtnts (vg:scale-offset-xy Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -137,10 +137,11 @@ ;; get extents, use knowledge of type ... ;; (define (vg:obj-get-extents drawing obj) (let ((type (vg:obj-type obj))) (case type + ((l)(vg:rect-get-extents obj)) ((r)(vg:rect-get-extents obj)) ((t)(vg:draw-text drawing obj draw: #f)) (else #f)))) (define (vg:rect-get-extents obj) @@ -388,10 +389,11 @@ ;; with draw = #f don't actually draw the object ;; (define (vg:draw-obj drawing obj #!key (draw #t)) ;; (print "obj type: " (vg:obj-type obj)) (case (vg:obj-type obj) + ((l)(vg:draw-line drawing obj draw: draw)) ((r)(vg:draw-rect drawing obj draw: draw)) ((t)(vg:draw-text drawing obj draw: draw)))) ;; given a rect obj draw it on the canvas applying first the drawing ;; scale and offset @@ -479,24 +481,24 @@ ;; (if fill-color ;; (begin ;; (canvas-foreground-set! cnv fill-color) ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) (if line-color - (canvas-foreground-set! cnv line-color) - (if fill-color - (canvas-foreground-set! cnv prev-foreground-color))) - (canvas-line! cnv llx ulx lly uly) + (canvas-foreground-set! cnv line-color)) + ;; (if fill-color + ;; (canvas-foreground-set! cnv prev-foreground-color))) + (canvas-line! cnv llx lly ulx uly) (canvas-foreground-set! cnv prev-foreground-color) (if text (let* ((prev-font (canvas-font cnv)) (font-changed (and font (not (equal? font prev-font))))) (if font-changed (canvas-font-set! cnv font)) (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) (let-values (((xmax ymax)(canvas-text-size cnv text))) (set! text-xmax xmax)(set! text-ymax ymax)) (if font-changed (canvas-font-set! cnv prev-font)))))) - (print "text-xmax: " text-xmax " text-ymax: " text-ymax) + ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) (if (vg:obj-extents obj) (vg:obj-extents obj) (if (not text) pts (if (and text-xmax text-ymax) @@ -551,11 +553,11 @@ (if font-changed (canvas-font-set! cnv font)) (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) (let-values (((xmax ymax)(canvas-text-size cnv text))) (set! text-xmax xmax)(set! text-ymax ymax)) (if font-changed (canvas-font-set! cnv prev-font)))))) - (print "text-xmax: " text-xmax " text-ymax: " text-ymax) + ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) (if (vg:obj-extents obj) (vg:obj-extents obj) (if (not text) pts (if (and text-xmax text-ymax)