Index: dashboard-context-menu.scm ================================================================== --- dashboard-context-menu.scm +++ dashboard-context-menu.scm @@ -20,23 +20,35 @@ ;;====================================================================== ;; implementation of context menu that pops up on ;; right click on test cell in Runs & Runs Summary Tabs ;;====================================================================== + +(module dashboard-context-menu + * (import format fmt) (import (prefix iup iup:)) (import canvas-draw) -(import srfi-1 +(import scheme + srfi-1 + chicken.base + chicken.condition + chicken.port chicken.file.posix + chicken.pathname + chicken.process + chicken.process-context + chicken.string regex regex-case srfi-69 (prefix sqlite3 sqlite3:)) (declare (unit dashboard-context-menu)) (declare (uses commonmod)) +(declare (uses configfmod)) (declare (uses dbmod)) (declare (uses gutils)) (declare (uses rmtmod)) (declare (uses ezstepsmod)) ;; (declare (uses sdb)) @@ -48,10 +60,11 @@ dbmod rmtmod ezstepsmod subrunmod debugprint + configfmod ) ;; (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -269,14 +282,15 @@ ;; 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) +(define (dashboard:custom-menu-items bdat 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* )))) + ;; (bdat-this-exe-dir-set! bdat (pathname-directory fullp)) + (mt-root (pathname-directory (pathname-directory (bdat-this-exe-dir bdat))))) (filter-map (lambda (var) (let* ((val (configf:lookup *configdat* "custom-context-menu-items" var)) (m (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val))) (if m @@ -337,17 +351,17 @@ (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) +(define (dashboard:context-menu bdat 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)) + (dashboard:custom-menu-items bdat 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 @@ -356,5 +370,7 @@ (apply iup:menu run-menu-items)) ,(iup:menu-item "Test" (apply iup:menu test-menu-items)) ,@custom-menu-items)))) + +) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -82,11 +82,11 @@ mtver processmod runsmod subrunmod vgmod - ) + dashboard-context-menu) (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2017 @@ -132,10 +132,11 @@ "-:p" ;; ignore the built in chicken profiling switch ) args:arg-hash 0)) +(make-and-init-bigdata) ;; check for MT_* environment variables and exit if found (if (not (args:get-arg "-test")) (begin (display "Checking for MT_ vars: ") (for-each (lambda (var) @@ -179,11 +180,11 @@ (if (or (args:get-arg "-rh5.11") (configf:lookup *configdat* "dashboard" "no-detachbox") (not (file-exists? "/etc/os-release"))) (set! iup:detachbox iup:vbox)) -(if (not (common:on-homehost?)) +#;(if (not (common:on-homehost?)) (begin (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) ;; RA => Might require revert for filters ;; create a watch dog to move changes from lt/.db/*.db to megatest.db @@ -2419,18 +2420,18 @@ (dboard:launch-testpanel run-id test-id)) ((member #\2 status-chars) ;; 2 is middle mouse button (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) - (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ) (else (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) - (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ) ) @@ -2977,11 +2978,11 @@ "%"))) (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path)))) - (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ;; (print "got here") ))