Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -68,10 +68,11 @@ mofiles/dbmod.o : mofiles/mtmod.o # mofiles/mtmod.o : mofiles/tcp-transportmod.o mofiles/megatestmod.o : mofiles/pkts.o mofiles/servermod.o mofiles/fsmod.o # mofiles/mtmod.o : mofiles/testsmod.o mofiles/subrunmod.o : mofiles/tasksmod.o +mofiles/dcommon.o : mofiles/tasksmod.o mofiles/launchmod.o : mofiles/subrunmod.o mofiles/runsmod.o mofiles/launchmod.o : mofiles/ezstepsmod.o mofiles/runsmod.o : mofiles/archivemod.o mofiles/testsmod.o : mofiles/dbmod.o Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -96,10 +96,14 @@ *toptest-paths* *transport-type* *common:this-exe-dir* + common:list-is-sublist + seconds->year-week/day-time + common:find-start-mark-and-mark-delta + common:with-orig-env alist->env-vars any->number any->number-if-possible assoc/default Index: dashboard-context-menu.scm ================================================================== --- dashboard-context-menu.scm +++ dashboard-context-menu.scm @@ -16,15 +16,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -;;====================================================================== -;; implementation of context menu that pops up on -;; right click on test cell in Runs & Runs Summary Tabs -;;====================================================================== - (declare (unit dashboard-context-menu)) ;; (declare (uses common)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses gutils)) @@ -57,307 +52,5 @@ subrunmod debugprint megatestmod ) -(define (dboard:launch-testpanel run-id test-id) - (let* ((dboardexe (common:find-local-megatest "dashboard")) - (cmd (conc dboardexe - " -test " run-id "," test-id - " &"))) - (system cmd))) - - -(define (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) - (list - (iup:menu-item - (conc "Rerun " testpatt) - #:action - (lambda (obj) - ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) - (common:run-a-command - (conc "megatest -run -target " target - " -runname " runname - " -testpatt " testpatt - " -preclean -clean-cache") - ))) - (iup:menu-item - "Rerun Complete Run" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target - " -runname " runname - " -testpatt % " - " -preclean -clean-cache")))) - (iup:menu-item - "Clean Complete Run" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt % ")))) - (iup:menu-item - "Kill Complete Run" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status KILLREQ,n/a -target " target - " -runname " runname - " -testpatt % " - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) - (iup:menu-item - "Delete Run Data" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt % " - " -keep-records")))))) - -(define (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) - (list - (iup:menu-item - (conc "Rerun " item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target - " -runname " runname - " -testpatt " item-test-path - " -preclean -clean-cache")))) - (iup:menu-item - (conc "Kill " item-test-path) - #:action - (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) - (common:run-a-command - (conc "megatest -set-state-status KILLREQ,n/a -target " target - " -runname " runname - " -testpatt " item-test-path - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) - (iup:menu-item - (conc "Delete data : " item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt " item-test-path - " -keep-records")))) - (iup:menu-item - (conc "Clean "item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt " item-test-path)))) - (iup:menu-item - "Start xterm" - #:action - (lambda (obj) - (dcommon:examine-xterm run-id test-id))) - ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&"))) - ;; (system cmd)))) - (iup:menu-item - "Edit testconfig" - #:action - (lambda (obj) - (let* ((all-tests (tests:get-all)) - (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") - "\\b(vim?|nano|pico)\\b")) - (editor (or (configf:lookup *configdat* "setup" "editor") - (get-environment-variable "VISUAL") - (get-environment-variable "EDITOR") "vi")) - (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) - (cmd (conc (if (string-search editor-rx editor) - (conc "xterm -e " editor) - editor) - " " tconfig " &"))) - (system cmd)))))) - -(define (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) - (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; # - (rundir (db:test-get-rundir test-info))) - - (iup:menu-item - "Step logs" - (apply iup:menu - (map (lambda (step) - (let ((stepname (vector-ref step 0)) - (logfile (vector-ref step 5)) - (status (vector-ref step 3))) - (iup:menu-item - (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")") - #:action (lambda (obj) - (let ((fullfile (conc rundir "/" logfile))) - (if (common:file-exists? fullfile) - (dcommon:run-html-viewer fullfile) - (message-window (conc "file " fullfile " not found")))))))) - steps))))) - -(define (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) - (list - - (iup:menu-item - "Test Control Panel" - #:action - (lambda (obj) - (dboard:launch-testpanel run-id test-id))) - - (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) - - (iup:menu-item - (conc "Rerun " item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target - " -runname " runname - " -testpatt " item-test-path - " -preclean -clean-cache")))) - - (iup:menu-item - "Start xterm" - #:action - (lambda (obj) - (dcommon:examine-xterm run-id test-id))) - - (iup:menu-item - (conc "Kill " item-test-path) - #:action - (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) - (common:run-a-command - (conc "megatest -set-state-status KILLREQ,n/a -target " target - " -runname " runname - " -testpatt " item-test-path - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) - - (let* ((rundir (db:test-get-rundir test-info)) - (has-subrun (subrun:subrun-test-initialized? rundir))) - (if has-subrun - (iup:menu-item - "Launch subrun dashboard" - #:action - (lambda (obj) - (subrun:launch-dashboard rundir))) - (iup:vbox))) - - (iup:menu-item - (conc "View Log " item-test-path) - #:action - (lambda (obj) - (let* ((rundir (db:test-get-rundir test-info)) - (logf (db:test-get-final_logf test-info)) - (fullfile (conc rundir "/" logf))) - (if (common:file-exists? fullfile) - (dcommon:run-html-viewer fullfile) - (message-window (conc "file " fullfile " not found."))))) - ) - )) -;; example section for megatest.config: -;; -;; -;; [custom-context-menu-items] -;; # : -;; item1 custom show run-id (%run-id%):echo "%run-id%" -;; item2 custom show test-id (%test-id%):echo "%test-id%" -;; item3 custom show target (%target%):echo "%target%" -;; item4 custom show test-name (%test-name%):echo "%test-name%" -;; item5 custom show test-patt (%test-patt%):echo "%test-patt%" -;; item6 custom show test-run-dir (%test-run-dir%):echo "%test-run-dir%" -;; item7 custom show run-area-home (%run-area-home%):echo "%run-area-home%" -;; item8 custom show megatest root (%mt-root%):echo "%mt-root%" -;; item9 custom ls : ls -lrt -;; item10 custom see $MT_RUN_AREA_HOME (not yet implemented) : echo $MT_RUN_AREA_HOME - -(define (dashboard:custom-menu-items run-id test-id target run-name test-name testpatt item-test-path test-info) - (let* ((vars (configf:section-vars *configdat* "custom-context-menu-items")) - (item-path (db:test-get-item-path test-info)) - (mt-root (pathname-directory (pathname-directory *common:this-exe-dir* )))) - (filter-map - (lambda (var) - (let* ((val (configf:lookup *configdat* "custom-context-menu-items" var)) - (m (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val))) - (if m - (let* ((menu-item-text-raw (list-ref m 1)) - (command-line-raw (list-ref m 2)) - (subst-alist ;; template vars - `(( "%run-id%" . ,run-id ) - ( "%test-id%" . ,test-id ) - ( "%target%" . ,target ) - ( "%test-name%" . ,test-name) - ( "%test-patt%" . ,testpatt) - ( "%test-run-dir%" . ,(db:test-get-rundir test-info)) - ( "%mt-root%" . ,mt-root) - ( "%run-name%" . ,run-name) - ( "%run-area-home%" . ,*toppath*) - ( "%item-path%" . ,item-path) - ( "%item-test-patt%" . ,item-test-path ))) - (command-line ;; replace template vars - (foldr - (lambda (x i) - (string-substitute - (car x) - (->string (cdr x)) - i - #t)) - command-line-raw - subst-alist)) - (menu-item-text ;; replace template vars - (foldr - (lambda (x i) - (string-substitute - (car x) - (->string (cdr x)) - i - #t)) - menu-item-text-raw - subst-alist))) - (iup:menu-item - (conc "*"menu-item-text) - #:action - (lambda (obj) - - (let* ((scheme-match (string-match "^#(\\(.*)" command-line))) - ;;(BB> "cmdline is >"command-line"<") - (common:with-env-vars - ;; TODO: with-env-vars - ;; TODO: with-env-vars MT_* - (runs:get-mt-env-alist run-id run-name target test-name item-path) - - (lambda () - (if scheme-match - (begin - (handle-exceptions - exn - (debug:print 0 *default-log-port* "error with custom menu scheme, exn=" exn) - (begin - ;;(BB> "gonna eval it!") - (eval (with-input-from-string (cadr scheme-match) read))))) - (common:run-a-command command-line with-vars: #t)))))))) - #f))) - vars))) - -(define (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) - (let* ((run-menu-items - (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) - (test-menu-items - (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) - (custom-menu-items - (dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) - (toplevel-menu-items - (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) - ) - (apply iup:menu - `(,@toplevel-menu-items - ,(iup:menu-item - "Run" - (apply iup:menu run-menu-items)) - ,(iup:menu-item - "Test" - (apply iup:menu test-menu-items)) - ,@custom-menu-items)))) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -25,12 +25,20 @@ (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses rmtmod)) (declare (uses testsmod)) (declare (uses mtargs)) -(declare (uses vg)) -(declare (uses vg.import)) +(declare (uses vgmod)) +;; (declare (uses vgmod.import)) +(declare (uses ezstepsmod)) +(declare (uses rmtmod)) +(declare (uses subrunmod)) +(declare (uses megatestmod)) +(declare (uses runsmod)) +(declare (uses tasksmod)) +(declare (uses dbfile)) +(declare (uses servermod)) (module dcommon * (import scheme @@ -37,32 +45,48 @@ chicken ports posix extras + format + fmt srfi-1 srfi-4 + srfi-13 + srfi-14 srfi-18 srfi-69 + sparse-vectors + files format (prefix iup iup:) canvas-draw canvas-draw-iup regex data-structures + directory-utils + pathname-expand typed-records matchable (prefix sqlite3 sqlite3:) + (prefix mtargs args:) commonmod configfmod rmtmod testsmod dbmod debugprint - vg - (prefix mtargs args:) + vgmod + ezstepsmod + rmtmod + subrunmod + megatestmod + runsmod + tasksmod + dbfile + servermod ) (include "megatest-version.scm") (include "common_records.scm") ;; (include "db_records.scm") @@ -390,11 +414,11 @@ ;; (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL")) ;; ;; (debug:print 2 *default-log-port* "run-changes: " run-changes) ;; ;; (debug:print 2 *default-log-port* "test-changes: " test-changes) ;; (list run-changes all-test-changes))) -#;(define (dcommon:runsdat-get-col-num dat target runname force-set) +(define (dcommon:runsdat-get-col-num dat target runname force-set) (let* ((runs-index (dboard:runsdat-runs-index dat)) (col-name (conc target "/" runname)) (res (hash-table-ref/default runs-index col-name #f))) (if res res @@ -401,11 +425,11 @@ (if force-set (let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index)))))) (hash-table-set! runs-index col-name max-col-num) max-col-num))))) -#;(define (dcommon:runsdat-get-row-num dat testname itempath force-set) +(define (dcommon:runsdat-get-row-num dat testname itempath force-set) (let* ((tests-index (dboard:runsdat-runs-index dat)) (row-name (conc testname "/" itempath)) (res (hash-table-ref/default runs-index row-name #f))) (if res res @@ -1971,11 +1995,11 @@ ;; (define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f)) (let* ((col-num (dcommon:runsdat-get-col-num dat target runname force-set)) (row-num (dcommon:runsdat-get-row-num dat testname itempath force-set))) (if (and row-num col-num) - (let ((tdat (dboard:testdat + (let ((tdat (make-dboard:testdat id: test-id state: state status: status))) (sparse-array-set! (dboard:runsdat-matrix-dat dat) col-num row-num tdat) tdat) @@ -3313,11 +3337,11 @@ (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) (define (new-tree-path->run-id rdat path) (if (not (null? path)) - (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f) + (hash-table-ref/default (dboard:rdat-path-run-ids rdat) path #f) #f)) ;; (define (dboard:get-tests-dat tabdat run-id last-update) ;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) ;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run @@ -6347,8 +6371,500 @@ (thread-join! th2) ) ) ) ) + +;;====================================================================== +;; T R E E S T U F F +;;====================================================================== + +;; path is a list of nodes, each the child of the previous +;; this routine returns the id so another node can be added +;; either as a leaf or as a branch +;; +;; BUG: This needs a stop sensor for when a branch is exhausted +;; +(define (tree:find-node obj path) + ;; start at the base of the tree + (if (null? path) + #f ;; or 0 ???? + (let loop ((hed (car path)) + (tal (cdr path)) + (depth 0) + (nodenum 0)) + ;; nodes in iup tree are 100% sequential so iterate over nodenum + (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes + (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) + (node-title (iup:attribute obj (conc "TITLE" nodenum)))) + (if (and (equal? depth node-depth) + (equal? hed node-title)) ;; yep, this is the one! + (if (null? tal) ;; end of the line + nodenum + (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum))) + ;; this is the case where we found part of the hierarchy but not + ;; all of it, i.e. the node-depth went from deep to less deep + (if (> depth node-depth) ;; (+ 1 node-depth)) + #f + (loop hed tal depth (+ nodenum 1))))) + #f)))) + +;; top is the top node name zeroeth node VALUE=0 +(define (tree:add-node obj top nodelst #!key (userdata #f)) + (let ((curr-top (iup:attribute obj "TITLE0"))) + (if (or (not (string? curr-top)) + (string-null? curr-top) + (string-match "^\\s*$" curr-top)) + (iup:attribute-set! obj "ADDBRANCH0" top)) + + + + (cond + ((not (equal? top (iup:attribute obj "TITLE0"))) + (debug:print 0 *default-log-port* "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) + ((null? nodelst)) + (else + (let loop ((hed (car nodelst)) + (tal (cdr nodelst)) + (depth 1) + (pathl (list top))) + ;; Because the tree dialog changes node numbers when + ;; nodes are added or removed we must look up nodes + ;; each and every time. 0 is the top node so default + ;; to that. + (let* ((newpath (append pathl (list hed))) + (parentnode (tree:find-node obj pathl)) + (nodenum (tree:find-node obj newpath))) + ;; Add the branch under lastnode if not found + (if (not nodenum) + (begin + (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) + ;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE? + (if userdata + (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) + (if (null? tal) + #t + ;; reset to top + (loop (car nodelst)(cdr nodelst) 1 (list top)))) + (if (null? tal) ;; if null here then this path has already been added + #t + (loop (car tal)(cdr tal)(+ depth 1) newpath))))))))) + +(define (tree:node->path obj nodenum) + (let loop ((currnode 0) + (path '())) + (let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode)))) + (node-title (iup:attribute obj (conc "TITLE" currnode))) + (trimpath (if (and (not (null? path)) + (> (length path) node-depth)) + (take path node-depth) + path)) + (newpath (append trimpath (list node-title)))) + (if (>= currnode nodenum) + newpath + (loop (+ currnode 1) + newpath))))) + +(define (tree:delete-node obj top node-path) ;; node-path is a list of strings + (let ((id (tree:find-node obj (cons top node-path)))) + (debug:print 0 *default-log-port* "Found node to remove " id " for path " top " " node-path) + (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED"))) + +#| + + (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 (cdr run-path)))) + (if run-id + (begin + (dboard:data-curr-run-id-set! data run-id) + (dashboard:update-run-summary-tab))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + )))) +|# + +;;====================================================================== +;; gutils +;; +;; NOTE: These functions will move to iuputils +;;====================================================================== + +(define (gutils:colors-similar? color1 color2) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) + (delta (map (lambda (a b)(abs (- a b))) c1 c2))) + (null? (filter (lambda (x)(> x 3)) delta)))) + +(define gutils:colors + '((PASS . "70 249 73") + (FAIL . "253 33 49") + (SKIP . "230 230 0"))) + +(define (gutils:get-color-spec effective-state) + (or (alist-ref effective-state gutils:colors) + (alist-ref 'FAIL gutils:colors))) + +;; BBnote - state status dashboard button color / text defined here +(define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) + ;; ((if get-label cadr car) + (case (string->symbol state) + ((COMPLETED) ;; ARCHIVED) + (case (string->symbol status) + ((PASS) (list "70 249 73" status)) + ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status)) + ((WARN WAIVED) (list "255 172 13" status)) + ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) + ((ABORT) (list "198 36 166" status)) + (else (list "253 33 49" status)))) + ((ARCHIVED) + (case (string->symbol status) + ((PASS) (list "70 170 73" status)) + ((WARN WAIVED) (list "200 130 13" status)) + ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) + (else (list "180 33 49" status)))) + ;; (if (equal? status "PASS") + ;; '("70 249 73" "PASS") + ;; (if (or (equal? status "WARN") + ;; (equal? status "WAIVED")) + ;; (list "255 172 13" status) + ;; (list "223 33 49" status)))) ;; greenish orangeish redish + ((LAUNCHED) (list "101 123 142" state)) + ((CHECK) (list "255 100 50" state)) + ((REMOTEHOSTSTART) (list "50 130 195" state)) + ((RUNNING STARTED) (list "9 131 232" state)) + ((KILLREQ) (list "39 82 206" state)) + ((KILLED) (list "234 101 17" state)) + ((NOT_STARTED) (case (string->symbol status) + ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state)) + (else (list "240 240 240" state)))) + ;; for xor mode below + ;; + ((CLEAN) + (case (string->symbol status) + ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these + (else (list "60 235 63" status)))) + ((DIRTY-BETTER) (list "160 255 153" status)) + ((DIRTY-WORSE) (list "165 42 42" status)) + ((BOTH-BAD) (list "180 33 49" status)) + + (else (list + ;; "192 192 192" + "222 222 221" + state)))) + +;;====================================================================== +;; implementation of context menu that pops up on +;; right click on test cell in Runs & Runs Summary Tabs +;;====================================================================== + +(define (dboard:launch-testpanel run-id test-id) + (let* ((dboardexe (common:find-local-megatest "dashboard")) + (cmd (conc dboardexe + " -test " run-id "," test-id + " &"))) + (system cmd))) + + +(define (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + (iup:menu-item + (conc "Rerun " testpatt) + #:action + (lambda (obj) + ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) + (common:run-a-command + (conc "megatest -run -target " target + " -runname " runname + " -testpatt " testpatt + " -preclean -clean-cache") + ))) + (iup:menu-item + "Rerun Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt % " + " -preclean -clean-cache")))) + (iup:menu-item + "Clean Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % ")))) + (iup:menu-item + "Kill Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt % " + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + (iup:menu-item + "Delete Run Data" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % " + " -keep-records")))))) + +(define (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + (iup:menu-item + (conc "Delete data : " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path + " -keep-records")))) + (iup:menu-item + (conc "Clean "item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path)))) + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&"))) + ;; (system cmd)))) + (iup:menu-item + "Edit testconfig" + #:action + (lambda (obj) + (let* ((all-tests (tests:get-all)) + (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") + "\\b(vim?|nano|pico)\\b")) + (editor (or (configf:lookup *configdat* "setup" "editor") + (get-environment-variable "VISUAL") + (get-environment-variable "EDITOR") "vi")) + (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) + (cmd (conc (if (string-search editor-rx editor) + (conc "xterm -e " editor) + editor) + " " tconfig " &"))) + (system cmd)))))) + +(define (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) + (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; # + (rundir (db:test-get-rundir test-info))) + + (iup:menu-item + "Step logs" + (apply iup:menu + (map (lambda (step) + (let ((stepname (vector-ref step 0)) + (logfile (vector-ref step 5)) + (status (vector-ref step 3))) + (iup:menu-item + (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")") + #:action (lambda (obj) + (let ((fullfile (conc rundir "/" logfile))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found")))))))) + steps))))) + +(define (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + + (iup:menu-item + "Test Control Panel" + #:action + (lambda (obj) + (dboard:launch-testpanel run-id test-id))) + + (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) + + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + + (let* ((rundir (db:test-get-rundir test-info)) + (has-subrun (subrun:subrun-test-initialized? rundir))) + (if has-subrun + (iup:menu-item + "Launch subrun dashboard" + #:action + (lambda (obj) + (subrun:launch-dashboard rundir))) + (iup:vbox))) + + (iup:menu-item + (conc "View Log " item-test-path) + #:action + (lambda (obj) + (let* ((rundir (db:test-get-rundir test-info)) + (logf (db:test-get-final_logf test-info)) + (fullfile (conc rundir "/" logf))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found."))))) + ) + )) +;; example section for megatest.config: +;; +;; +;; [custom-context-menu-items] +;; # : +;; item1 custom show run-id (%run-id%):echo "%run-id%" +;; item2 custom show test-id (%test-id%):echo "%test-id%" +;; item3 custom show target (%target%):echo "%target%" +;; item4 custom show test-name (%test-name%):echo "%test-name%" +;; item5 custom show test-patt (%test-patt%):echo "%test-patt%" +;; item6 custom show test-run-dir (%test-run-dir%):echo "%test-run-dir%" +;; item7 custom show run-area-home (%run-area-home%):echo "%run-area-home%" +;; item8 custom show megatest root (%mt-root%):echo "%mt-root%" +;; item9 custom ls : ls -lrt +;; item10 custom see $MT_RUN_AREA_HOME (not yet implemented) : echo $MT_RUN_AREA_HOME + +(define (dashboard:custom-menu-items run-id test-id target run-name test-name testpatt item-test-path test-info) + (let* ((vars (configf:section-vars *configdat* "custom-context-menu-items")) + (item-path (db:test-get-item-path test-info)) + (mt-root (pathname-directory (pathname-directory *common:this-exe-dir* )))) + (filter-map + (lambda (var) + (let* ((val (configf:lookup *configdat* "custom-context-menu-items" var)) + (m (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val))) + (if m + (let* ((menu-item-text-raw (list-ref m 1)) + (command-line-raw (list-ref m 2)) + (subst-alist ;; template vars + `(( "%run-id%" . ,run-id ) + ( "%test-id%" . ,test-id ) + ( "%target%" . ,target ) + ( "%test-name%" . ,test-name) + ( "%test-patt%" . ,testpatt) + ( "%test-run-dir%" . ,(db:test-get-rundir test-info)) + ( "%mt-root%" . ,mt-root) + ( "%run-name%" . ,run-name) + ( "%run-area-home%" . ,*toppath*) + ( "%item-path%" . ,item-path) + ( "%item-test-patt%" . ,item-test-path ))) + (command-line ;; replace template vars + (foldr + (lambda (x i) + (string-substitute + (car x) + (->string (cdr x)) + i + #t)) + command-line-raw + subst-alist)) + (menu-item-text ;; replace template vars + (foldr + (lambda (x i) + (string-substitute + (car x) + (->string (cdr x)) + i + #t)) + menu-item-text-raw + subst-alist))) + (iup:menu-item + (conc "*"menu-item-text) + #:action + (lambda (obj) + + (let* ((scheme-match (string-match "^#(\\(.*)" command-line))) + ;;(BB> "cmdline is >"command-line"<") + (common:with-env-vars + ;; TODO: with-env-vars + ;; TODO: with-env-vars MT_* + (runs:get-mt-env-alist run-id run-name target test-name item-path) + + (lambda () + (if scheme-match + (begin + (handle-exceptions + exn + (debug:print 0 *default-log-port* "error with custom menu scheme, exn=" exn) + (begin + ;;(BB> "gonna eval it!") + (eval (with-input-from-string (cadr scheme-match) read))))) + (common:run-a-command command-line with-vars: #t)))))))) + #f))) + vars))) + +(define (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) + (let* ((run-menu-items + (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (test-menu-items + (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (custom-menu-items + (dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (toplevel-menu-items + (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + ) + (apply iup:menu + `(,@toplevel-menu-items + ,(iup:menu-item + "Run" + (apply iup:menu run-menu-items)) + ,(iup:menu-item + "Test" + (apply iup:menu test-menu-items)) + ,@custom-menu-items)))) ) Index: ezstepsmod.scm ================================================================== --- ezstepsmod.scm +++ ezstepsmod.scm @@ -45,11 +45,13 @@ (declare (uses fsmod)) (use srfi-69) (module ezstepsmod - () + ( + ezsteps:spawn-run-from + ) (import scheme) (cond-expand (chicken-4 @@ -63,11 +65,10 @@ posix posix-extras regex regex-case sparse-vectors - ) (use srfi-69)) (chicken-5 (import (prefix sqlite3 sqlite3:) chicken.base Index: gutils.scm ================================================================== --- gutils.scm +++ gutils.scm @@ -23,70 +23,5 @@ (use canvas-draw) (use srfi-1 regex regex-case srfi-69) (declare (unit gutils)) -;; NOTE: These functions will move to iuputils - -(define (gutils:colors-similar? color1 color2) - (let* ((c1 (map string->number (string-split color1))) - (c2 (map string->number (string-split color2))) - (delta (map (lambda (a b)(abs (- a b))) c1 c2))) - (null? (filter (lambda (x)(> x 3)) delta)))) - -(define gutils:colors - '((PASS . "70 249 73") - (FAIL . "253 33 49") - (SKIP . "230 230 0"))) - -(define (gutils:get-color-spec effective-state) - (or (alist-ref effective-state gutils:colors) - (alist-ref 'FAIL gutils:colors))) - -;; BBnote - state status dashboard button color / text defined here -(define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) - ;; ((if get-label cadr car) - (case (string->symbol state) - ((COMPLETED) ;; ARCHIVED) - (case (string->symbol status) - ((PASS) (list "70 249 73" status)) - ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status)) - ((WARN WAIVED) (list "255 172 13" status)) - ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) - ((ABORT) (list "198 36 166" status)) - (else (list "253 33 49" status)))) - ((ARCHIVED) - (case (string->symbol status) - ((PASS) (list "70 170 73" status)) - ((WARN WAIVED) (list "200 130 13" status)) - ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) - (else (list "180 33 49" status)))) - ;; (if (equal? status "PASS") - ;; '("70 249 73" "PASS") - ;; (if (or (equal? status "WARN") - ;; (equal? status "WAIVED")) - ;; (list "255 172 13" status) - ;; (list "223 33 49" status)))) ;; greenish orangeish redish - ((LAUNCHED) (list "101 123 142" state)) - ((CHECK) (list "255 100 50" state)) - ((REMOTEHOSTSTART) (list "50 130 195" state)) - ((RUNNING STARTED) (list "9 131 232" state)) - ((KILLREQ) (list "39 82 206" state)) - ((KILLED) (list "234 101 17" state)) - ((NOT_STARTED) (case (string->symbol status) - ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state)) - (else (list "240 240 240" state)))) - ;; for xor mode below - ;; - ((CLEAN) - (case (string->symbol status) - ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these - (else (list "60 235 63" status)))) - ((DIRTY-BETTER) (list "160 255 153" status)) - ((DIRTY-WORSE) (list "165 42 42" status)) - ((BOTH-BAD) (list "180 33 49" status)) - - (else (list - ;; "192 192 192" - "222 222 221" - state)))) - Index: mtargs/mtargs.scm ================================================================== --- mtargs/mtargs.scm +++ mtargs/mtargs.scm @@ -103,6 +103,9 @@ (define (any-defined? . args) (not (null? (filter (lambda (x) x) (map get-arg args))))) +(define (remove-arg-from-ht arg) + (hash-table-delete! arg-hash arg)) + ) Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -29,10 +29,11 @@ (declare (uses apimod)) (declare (uses servermod)) (module rmtmod ( + rmt:get-tests-for-run-state-status rmt:tasks-get-last rmt:read-test-data rmt:get-targets rmt:get-run-stats rmt:get-key-vals Index: runsmod.scm ================================================================== --- runsmod.scm +++ runsmod.scm @@ -45,10 +45,11 @@ (use srfi-69) (module runsmod ( + runs:get-mt-env-alist setup-env-defaults runs:clean-cache rmt:find-and-mark-incomplete launch:setup launch:end-of-run-check Index: task_records.scm ================================================================== --- task_records.scm +++ task_records.scm @@ -15,30 +15,5 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -;; make-vector-record tasks task id action owner state target name test item params creation_time execution_time -(define (make-tasks:task)(make-vector 11)) -(define-inline (tasks:task-get-id vec) (vector-ref vec 0)) -(define-inline (tasks:task-get-action vec) (vector-ref vec 1)) -(define-inline (tasks:task-get-owner vec) (vector-ref vec 2)) -(define-inline (tasks:task-get-state vec) (vector-ref vec 3)) -(define-inline (tasks:task-get-target vec) (vector-ref vec 4)) -(define-inline (tasks:task-get-name vec) (vector-ref vec 5)) -(define-inline (tasks:task-get-testpatt vec) (vector-ref vec 6)) -(define-inline (tasks:task-get-keylock vec) (vector-ref vec 7)) -(define-inline (tasks:task-get-params vec) (vector-ref vec 8)) -(define-inline (tasks:task-get-creation_time vec) (vector-ref vec 9)) -(define-inline (tasks:task-get-execution_time vec) (vector-ref vec 10)) - -(define-inline (tasks:task-set-state! vec val)(vector-set! vec 3 val)) - - -;; make-vector-record tasks monitor id pid start_time last_update hostname username -(define (make-tasks:monitor)(make-vector 5)) -(define-inline (tasks:monitor-get-id vec) (vector-ref vec 0)) -(define-inline (tasks:monitor-get-pid vec) (vector-ref vec 1)) -(define-inline (tasks:monitor-get-start_time vec) (vector-ref vec 2)) -(define-inline (tasks:monitor-get-last_update vec) (vector-ref vec 3)) -(define-inline (tasks:monitor-get-hostname vec) (vector-ref vec 4)) -(define-inline (tasks:monitor-get-username vec) (vector-ref vec 5)) Index: tasksmod.scm ================================================================== --- tasksmod.scm +++ tasksmod.scm @@ -55,10 +55,12 @@ common:exit-on-version-changed task:get-run-times task:get-test-times tasks:sync-to-postgres tests:get-full-data + tasks:task-get-testpatt + ) (import scheme) (cond-expand (chicken-4 @@ -1883,7 +1885,32 @@ ) (hash-table-keys missing-waitons) ) )) +;; make-vector-record tasks task id action owner state target name test item params creation_time execution_time +(define (make-tasks:task)(make-vector 11)) +(define (tasks:task-get-id vec) (vector-ref vec 0)) +(define (tasks:task-get-action vec) (vector-ref vec 1)) +(define (tasks:task-get-owner vec) (vector-ref vec 2)) +(define (tasks:task-get-state vec) (vector-ref vec 3)) +(define (tasks:task-get-target vec) (vector-ref vec 4)) +(define (tasks:task-get-name vec) (vector-ref vec 5)) +(define (tasks:task-get-testpatt vec) (vector-ref vec 6)) +(define (tasks:task-get-keylock vec) (vector-ref vec 7)) +(define (tasks:task-get-params vec) (vector-ref vec 8)) +(define (tasks:task-get-creation_time vec) (vector-ref vec 9)) +(define (tasks:task-get-execution_time vec) (vector-ref vec 10)) + +(define (tasks:task-set-state! vec val)(vector-set! vec 3 val)) + + +;; make-vector-record tasks monitor id pid start_time last_update hostname username +(define (make-tasks:monitor)(make-vector 5)) +(define (tasks:monitor-get-id vec) (vector-ref vec 0)) +(define (tasks:monitor-get-pid vec) (vector-ref vec 1)) +(define (tasks:monitor-get-start_time vec) (vector-ref vec 2)) +(define (tasks:monitor-get-last_update vec) (vector-ref vec 3)) +(define (tasks:monitor-get-hostname vec) (vector-ref vec 4)) +(define (tasks:monitor-get-username vec) (vector-ref vec 5)) ) Index: tree.scm ================================================================== --- tree.scm +++ tree.scm @@ -23,10 +23,11 @@ (declare (uses debugprint)) (declare (uses launch)) (declare (uses gutils)) (declare (uses server)) (declare (uses dcommon)) + (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) @@ -40,119 +41,5 @@ ;; (include "megatest-version.scm") ;; (include "common_records.scm") ;; (include "db_records.scm") ;; (include "key_records.scm") -;;====================================================================== -;; T R E E S T U F F -;;====================================================================== - -;; path is a list of nodes, each the child of the previous -;; this routine returns the id so another node can be added -;; either as a leaf or as a branch -;; -;; BUG: This needs a stop sensor for when a branch is exhausted -;; -(define (tree:find-node obj path) - ;; start at the base of the tree - (if (null? path) - #f ;; or 0 ???? - (let loop ((hed (car path)) - (tal (cdr path)) - (depth 0) - (nodenum 0)) - ;; nodes in iup tree are 100% sequential so iterate over nodenum - (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes - (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) - (node-title (iup:attribute obj (conc "TITLE" nodenum)))) - (if (and (equal? depth node-depth) - (equal? hed node-title)) ;; yep, this is the one! - (if (null? tal) ;; end of the line - nodenum - (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum))) - ;; this is the case where we found part of the hierarchy but not - ;; all of it, i.e. the node-depth went from deep to less deep - (if (> depth node-depth) ;; (+ 1 node-depth)) - #f - (loop hed tal depth (+ nodenum 1))))) - #f)))) - -;; top is the top node name zeroeth node VALUE=0 -(define (tree:add-node obj top nodelst #!key (userdata #f)) - (let ((curr-top (iup:attribute obj "TITLE0"))) - (if (or (not (string? curr-top)) - (string-null? curr-top) - (string-match "^\\s*$" curr-top)) - (iup:attribute-set! obj "ADDBRANCH0" top)) - - - - (cond - ((not (equal? top (iup:attribute obj "TITLE0"))) - (debug:print 0 *default-log-port* "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) - ((null? nodelst)) - (else - (let loop ((hed (car nodelst)) - (tal (cdr nodelst)) - (depth 1) - (pathl (list top))) - ;; Because the tree dialog changes node numbers when - ;; nodes are added or removed we must look up nodes - ;; each and every time. 0 is the top node so default - ;; to that. - (let* ((newpath (append pathl (list hed))) - (parentnode (tree:find-node obj pathl)) - (nodenum (tree:find-node obj newpath))) - ;; Add the branch under lastnode if not found - (if (not nodenum) - (begin - (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) - ;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE? - (if userdata - (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) - (if (null? tal) - #t - ;; reset to top - (loop (car nodelst)(cdr nodelst) 1 (list top)))) - (if (null? tal) ;; if null here then this path has already been added - #t - (loop (car tal)(cdr tal)(+ depth 1) newpath))))))))) - -(define (tree:node->path obj nodenum) - (let loop ((currnode 0) - (path '())) - (let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode)))) - (node-title (iup:attribute obj (conc "TITLE" currnode))) - (trimpath (if (and (not (null? path)) - (> (length path) node-depth)) - (take path node-depth) - path)) - (newpath (append trimpath (list node-title)))) - (if (>= currnode nodenum) - newpath - (loop (+ currnode 1) - newpath))))) - -(define (tree:delete-node obj top node-path) ;; node-path is a list of strings - (let ((id (tree:find-node obj (cons top node-path)))) - (debug:print 0 *default-log-port* "Found node to remove " id " for path " top " " node-path) - (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED"))) - -#| - - (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 (cdr run-path)))) - (if run-id - (begin - (dboard:data-curr-run-id-set! data run-id) - (dashboard:update-run-summary-tab))) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - )))) -|#