Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -228,15 +228,17 @@ # base64 dot-locking \ # csv-xml z3 # "(define (toplevel-command . a) #f)" +# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ + readline-fix.scm : - if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ - echo "(use-legacy-bindings)" > readline-fix.scm; \ + if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \ + echo "(define *use-new-readline* #f)" > readline-fix.scm; \ else \ - echo "" > readline-fix.scm;\ + echo "(define *use-new-readline* #t)" > readline-fix.scm;\ fi altdb.scm : echo ";; optional alternate db setup" > altdb.scm echo "(define *available-db* (make-hash-table))" >> altdb.scm 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" @@ -1752,20 +1754,65 @@ (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 0) + (let ((popup-menu (iup:menu + (iup:menu-item + "Run" + (iup:menu + (iup:menu-item + "Rerun" + #:action + (lambda (obj)(print "Rerun"))) + (iup:menu-item + "Start xterm" + #:action + (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 " -xterm " run-id "," test-id "&"))) + (system cmd)) + ;; (lambda (x) + ;; (if (directory-exists? rundir) + ;; (let ((shell (if (get-environment-variable "SHELL") + ;; (conc "-e " (get-environment-variable "SHELL")) + ;; ""))) + ;; (common:without-vars + ;; (conc "cd " rundir + ;; ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&") + ;; "MT_.*")) + ;; (message-window (conc "Directory " rundir " not found")))) + )))))) + (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 @@ -1932,10 +1979,24 @@ (>= test-id 0)) (examine-test run-id test-id) (begin (debug:print 3 "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. @@ -1900,14 +1901,19 @@ ;; (import csi) (import readline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (include "readline-fix.scm") - (gnu-history-install-file-manager - (string-append - (or (get-environment-variable "HOME") ".") "/.megatest_history")) - (current-input-port (make-gnu-readline-port "megatest> ")) + (if *use-new-readline* + (begin + (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) + (current-input-port (make-readline-port "megatest> "))) + (begin + (gnu-history-install-file-manager + (string-append + (or (get-environment-variable "HOME") ".") "/.megatest_history")) + (current-input-port (make-gnu-readline-port "megatest> ")))) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))) (db:close-all dbstruct)) (exit)))