@@ -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))))