ADDED dashboard-context-menu-inc.scm
Index: dashboard-context-menu-inc.scm
==================================================================
--- /dev/null
+++ dashboard-context-menu-inc.scm
@@ -0,0 +1,335 @@
+;;======================================================================
+;; Copyright 2006-2012, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; 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
+;;======================================================================
+
+
+(define (dboard:launch-testpanel run-id test-id)
+ (let* (;; (cfg-sh (conc *common:this-exe-dir* "/cfg.sh"))
+ ;; (cmd (conc
+ ;; (if (common:file-exists? cfg-sh)
+ ;; (conc "source "cfg-sh" && ")
+ ;; "")
+ ;; *common:this-exe-fullpath*
+ ;; " -test " run-id "," test-id
+ ;; " &"))
+ (cmd (conc *common:this-exe-dir*"/../dashboard "
+ "-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]
+;; #