Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -40,10 +40,16 @@ (define (config:assoc-safe-add alist key val #!key (metadata #f)) (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) (append newalist (list (if metadata (list key val metadata) (list key val)))))) + + +(define (configf:set-section-var cfgdat section var value) + (let ((sect (hash-table-ref/default cfgdat section '()))) + (hash-table-set! cfgdat section (config:assoc-safe-add sect var value)))) + (define (config:eval-string-in-environment str) (handle-exceptions exn (begin @@ -596,5 +602,7 @@ (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f))) (if fname (print "# " var "=>" fname)) (print var " " val))) section-dat))) ;; (print "section-dat: " section-dat)) (hash-table->alist data))) + + Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -49,10 +49,11 @@ Usage: dashboard [options] -h : this help -server host:port : connect to host:port instead of db access -test run-id,test-id : control test identified by testid + -xterm run-id,test-id : Start a new xterm with specified run-id and test-id -guimonitor : control panel for runs Misc -rows N : set number of rows ")) @@ -61,10 +62,11 @@ (define remargs (args:get-args (argv) (list "-rows" "-run" "-test" + "-xterm" "-debug" "-host" "-transport" ) (list "-h" @@ -1751,20 +1753,73 @@ (else (let* ((button-key (mkstr runnum testnum)) (butn (iup:button "" ;; button-key #:size "60x15" #:expand "HORIZONTAL" - #:fontsize "10" - #:action (lambda (x) - (let* ((toolpath (car (argv))) - (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key)) - (test-id (db:test-get-id (vector-ref buttndat 3))) - (run-id (db:test-get-run_id (vector-ref buttndat 3))) - (cmd (conc toolpath " -test " run-id "," test-id "&"))) - ;(print "Launching " cmd) - (system cmd)))))) - (hash-table-set! (d:alldat-buttondat *alldat*) button-key (vector 0 "100 100 100" button-key #f #f)) + #:fontsize "10" + ;; :action (lambda (x) + ;; (let* ((toolpath (car (argv))) + ;; (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key)) + ;; (test-id (db:test-get-id (vector-ref buttndat 3))) + ;; (run-id (db:test-get-run_id (vector-ref buttndat 3))) + ;; (cmd (conc toolpath " -test " run-id "," test-id "&"))) + ;; ;(print "Launching " cmd) + ;; (system cmd))) + #: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) + (let* ((toolpath (car (argv))) + (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key)) + (test-id (db:test-get-id (vector-ref buttndat 3))) + (run-id (db:test-get-run_id (vector-ref buttndat 3))) + (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) + (popup-menu (iup:menu + (iup:menu-item + "Run" + (iup:menu + (iup:menu-item + "Rerun" + #:action + (lambda (obj)(print "Rerun"))))) + (iup:menu-item + "Test" + (iup:menu + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (let* ((cmd (conc toolpath " -xterm " run-id "," test-id "&"))) + (system cmd)))) + (iup:menu-item + "Edit testconfig" + #:action + (lambda (obj) + (let* ((all-tests (tests:get-all)) + (editor (or (get-environment-variable "VISUAL") + (get-environment-variable "EDITOR") "gvim")) + (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) + (cmd (conc (if (string-search "\\b(vim?|nano|pico)\\b") + (conc "xterm -e " editor) + editor) + " " tconfig))) + (system cmd)))) + ))))) + (iup:show popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + (print "got here"))) + (if (eq? pressed 0) + (let* ((toolpath (car (argv))) + (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key)) + (test-id (db:test-get-id (vector-ref buttndat 3))) + (run-id (db:test-get-run_id (vector-ref buttndat 3))) + (cmd (conc toolpath " -test " run-id "," test-id "&"))) + (system cmd))) + ))))) + (hash-table-set! (d:alldat-buttondat *alldat*) button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show (iup:dialog @@ -1931,10 +1986,24 @@ (>= test-id 0)) (examine-test run-id test-id) (begin (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) + ((args:get-arg "-xterm") ;; run-id,test-id + (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-xterm") ",")))) + (if (> (length d) 1) + d + (list #f #f)))) + (run-id (car dat)) + (test-id (cadr dat))) + (if (and (number? run-id) + (number? test-id) + (>= test-id 0)) + (dcommon:examine-xterm run-id test-id) + (begin + (debug:print 3 "INFO: tried to open xterm with invalid run-id,test-id. " (args:get-arg "-xterm")) + (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor (d:alldat-dblocal data))) (else (set! uidat (make-dashboard-buttons data ;; (d:alldat-dblocal data) (d:alldat-numruns data) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -318,11 +318,37 @@ (status (vector-ref hed 4)) (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))))))) - + +(define (dcommon:examine-xterm run-id test-id) + (let* + ((testdat (rmt:get-test-info-by-id run-id test-id))) + (if (not testdat) + (begin + (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") + (exit 1)) + (let* + ((rundir (if testdat + (db:test-get-rundir testdat) + logfile)) + (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) + (xterm (lambda () + (if (directory-exists? rundir) + (let* ((shell (if (get-environment-variable "SHELL") + (conc "-e " (get-environment-variable "SHELL")) + "")) + (command (conc "cd " rundir + ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) + (print "Command =" command) + (common:without-vars + command + "MT_.*")) + (message-window (conc "Directory " rundir " not found")))))) + (xterm) + (print "Adding xterm code"))))) ;;====================================================================== ;; D A T A T A B L E S ;;====================================================================== Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -36,10 +36,11 @@ (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) (declare (uses daemon)) (declare (uses db)) +(declare (uses dcommon)) (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. Index: multi-dboard.scm ================================================================== --- multi-dboard.scm +++ multi-dboard.scm @@ -163,10 +163,11 @@ areas ;; hash of areaname -> area-rec current-window-id ;; current-tab-id ;; update-needed ;; flag to indicate that the tab pointed to by current tab id needs refreshing immediately tabs ;; hash of tab-id -> areaname (??) should be of type "tab" + groupn ;; ) ;; all the components of an area display, all fits into a tab but ;; parts may be swapped in/out as needed ;; @@ -412,16 +413,26 @@ (view-matrix (iup:matrix ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f)) #:expand "YES" ;; #:fittosize "YES" #:resizematrix "YES" + #:menucontext "YES" #:scrollbar "YES" #:numcol 100 #:numlin 100 #:numcol-visible 3 #:numlin-visible 20 #:click-cb (lambda (obj lin col status) + (let ((popup-menu (iup:menu + (iup:menu-item "Remove test" + #:action (lambda (obj)(print "Removing test")))))) + (iup:show popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + + (print "got here")) (print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE")))))) ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES") (iup:attribute-set! view-matrix "WIDTH0" "100") ;; (dboard:data-set-runs-matrix! *data* runs-matrix) @@ -517,10 +528,48 @@ ;;====================================================================== ;; D A S H B O A R D ;;====================================================================== + +;; The main menu +(define (dcommon:main-menu data) + (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) + (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options + (iup:menu-item "Open" action: (lambda (obj) + (let* ((area-name (iup:textbox #:expand "HORIZONTAL")) + (fd (iup:file-dialog #:dialogtype "DIR")) + (top (iup:show fd #:modal? "YES"))) + (iup:attribute-set! source-tb "VALUE" + (iup:attribute fd "VALUE")) + (iup:destroy! fd)))) + (iup:menu-item "Open area" action: (lambda (obj) + (let* ((area-name (iup:textbox #:expand "HORIZONTAL")) + (fd (iup:file-dialog #:dialogtype "DIR")) + (top (iup:show fd #:modal? "YES")) + ;;(source-tb (iup:textbox #:expand "HORIZONTAL")) + (cfgdat (data-cfgdat data)) + (fname (conc (getenv "HOME") "/.megatest/" (data-groupn data) ".dat")) + ) + ;;(iup:attribute-set! source-tb "VALUE" + ;; (iup:attribute fd "VALUE")) + (configf:set-section-var cfgdat "lvqa" "path" (iup:attribute fd "VALUE")) + (configf:write-alist cfgdat fname) + (iup:destroy! fd)))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Tools" (iup:menu + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) + (define (dashboard:area-panel aname data window-id) (let* ((apath (configf:lookup (data-cfgdat data) aname "path")) ;; (hash-table-ref (dboard:data-cfgdat data) area-name)) ;; (hash-table-ref (dboard:data-cfgdat data) aname)) (area-dat (dashboard:init-area data aname apath)) @@ -554,11 +603,11 @@ ;; Main Panel ;; (define (dashboard:main-panel data window-id) (iup:dialog #:title "Megatest Control Panel" -;; #:menu (dcommon:main-menu data) + #:menu (dcommon:main-menu data) #:shrink "YES" (iup:vbox (let* ((area-names (hash-table-keys (data-cfgdat data))) (area-panels (map (lambda (aname) (dashboard:area-panel aname data window-id)) @@ -749,13 +798,17 @@ (define (dboard:read-mtconf apath) (let* ((mtconffile (conc apath "/megatest.config"))) (call-with-environment-variables (list (cons "MT_RUN_AREA_HOME" apath)) (lambda () - (read-config mtconffile (make-hash-table) #f)) ;; megatest.config - ))) - + (let ((res (read-config mtconffile (make-hash-table) #f))) ;; megatest.config + (if (hash-table? res) + res + (begin + (debug:print 0 "WARNING: failed to read " mtconffile) + (make-hash-table)))))))) + ;;====================================================================== ;; G U I S T U F F ;;====================================================================== @@ -771,13 +824,15 @@ (make-hash-table) ;; areaname -> area-rec 0 ;; current window id 0 ;; current tab id #f ;; redraw needed for current tab id (make-hash-table) ;; tab-id -> areaname + groupn ))) (hash-table-set! *windows* window-id data) (iup:show (dashboard:main-panel data window-id)) + ;;(iup:show (layout-dialog (dashboard:main-panel data window-id))) (iup:main-loop))) ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) Index: tests/fullrun/multi-dboard.sh ================================================================== --- tests/fullrun/multi-dboard.sh +++ tests/fullrun/multi-dboard.sh @@ -14,11 +14,11 @@ # EOF # fi if [[ ! -e "$HOME/.megatest/default.dat" ]];then cat > "$HOME/.megatest/default.dat" << EOF [fullrun] -path /mfs/matt/data/megatest/tests/fullrun +path /home/USER/myMegatestArea order 1 # [bigrun] # path /mfs/matt/data/megatest/tests/fdktestqa/testqa # order 2 # [local_fullrun] @@ -25,6 +25,6 @@ # path /home/matt/data/megatest/tests/fullrun # order 3 EOF fi -csi -I ../.. multi-dboard-load-all.scm +/nfs/pdx/disks/icf_external/pkgs/chicken/4.10.0/bin/csi -I ../.. multi-dboard-load-all.scm