Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -166,10 +166,11 @@ ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) ;; TASKS ((tasks-add) (apply tasks:add dbstruct params)) ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) + ((tasks-get-last) (apply tasks:get-last dbstruct params)) ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -917,10 +917,17 @@ (hash-table-for-each vars (lambda (var val) (setenv var val))) vars)) + +(define (common:run-a-command cmd) + (let ((fullcmd (conc (dtests:get-pre-command) + cmd + (dtests:get-post-command)))) + (debug:print-info 02 *default-log-port* "Running command: " fullcmd) + (common:without-vars fullcmd "MT_.*"))) ;;====================================================================== ;; T I M E A N D D A T E ;;====================================================================== Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -575,16 +575,12 @@ ;(mutex-unlock! mx1) ))))) lbl)) (store-button store-label) (command-proc (lambda (command-text-box) - (let* ((cmd (iup:attribute command-text-box "VALUE")) - (fullcmd (conc (dtests:get-pre-command) - cmd - (dtests:get-post-command)))) - (debug:print-info 02 *default-log-port* "Running command: " fullcmd) - (common:without-vars fullcmd "MT_.*")))) + (let* ((cmd (iup:attribute command-text-box "VALUE"))) + (common:run-a-command cmd)))) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10" #:action (lambda (obj cnum val) ;; (print "cnum=" cnum) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -38,10 +38,11 @@ (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") +(include "task_records.scm") (include "megatest-fossil-hash.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " @@ -1841,80 +1842,100 @@ (vector-set! runsvec runnum testvec) (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) (loop (+ runnum 1) 0 (make-vector ntests) '())) (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))) - #: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-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") "gvim")) - (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)))) - ))))) - (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)) + (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))) + #: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))) + (run-info (rmt:get-run-info run-id)) + (target (rmt:get-target run-id)) + (runname (db:get-value-by-header (db:get-rows run-info) + (db:get-header run-info) "runname")) + (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) + (testpatt (let ((tlast (rmt:tasks-get-last target runname))) + (if tlast + (let ((tpatt (tasks:task-get-testpatt tlast))) + (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 + "%" + tpatt)) + "%"))) + (popup-menu (iup:menu + (iup:menu-item + "Run" + (iup:menu + (iup:menu-item + (conc "Rerun " testpatt) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -run -target " target + " -runname " runname + " -testpatt " testpatt + " -preclean -clean-cache") + ;; (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-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)))) + ))))) + (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 Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -696,10 +696,13 @@ (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params))) (define (rmt:tasks-set-state-given-param-key param-key new-state) (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) +(define (rmt:tasks-get-last target runname) + (rmt:send-receive 'tasks-get-last #f (list target runname))) + ;;====================================================================== ;; A R C H I V E S ;;====================================================================== (define (rmt:archive-get-allocations testname itempath dneeded) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -224,17 +224,17 @@ (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (begin (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf) #f))) + (if (not test-patts) ;; first time in - adjust testpatt + (set! test-patts (common:args-get-testpatt runconf))) + ;; register this run in monitor.db (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) (rmt:tasks-set-state-given-param-key task-key "running") - (if (not test-patts) ;; first time in - adjust testpatt - (set! test-patts (common:args-get-testpatt runconf))) - ;; Now generate all the tests lists (set! all-tests-registry (tests:get-all)) ;; hash of testname => path-to-test (set! all-test-names (hash-table-keys all-tests-registry)) (set! test-names (tests:filter-test-names all-test-names test-patts)) Index: task_records.scm ================================================================== --- task_records.scm +++ task_records.scm @@ -15,12 +15,12 @@ (define-inline (tasks:task-get-action vec) (vector-ref vec 1)) (define-inline (tasks:task-get-owner vec) (vector-ref vec 2)) (define-inline (tasks:task-get-state vec) (vector-ref vec 3)) (define-inline (tasks:task-get-target vec) (vector-ref vec 4)) (define-inline (tasks:task-get-name vec) (vector-ref vec 5)) -(define-inline (tasks:task-get-test vec) (vector-ref vec 6)) -(define-inline (tasks:task-get-item vec) (vector-ref vec 7)) +(define-inline (tasks:task-get-testpatt vec) (vector-ref vec 6)) +(define-inline (tasks:task-get-keylock vec) (vector-ref vec 7)) (define-inline (tasks:task-get-params vec) (vector-ref vec 8)) (define-inline (tasks:task-get-creation_time vec) (vector-ref vec 9)) (define-inline (tasks:task-get-execution_time vec) (vector-ref vec 10)) (define-inline (tasks:task-set-state! vec val)(vector-set! vec 3 val)) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -548,10 +548,21 @@ ;;====================================================================== ;; NOTE: It might be good to add one more layer of checking to ensure ;; that no task gets run in parallel. +;; id INTEGER PRIMARY KEY, +;; action TEXT DEFAULT '', +;; owner TEXT, +;; state TEXT DEFAULT 'new', +;; target TEXT DEFAULT '', +;; name TEXT DEFAULT '', +;; testpatt TEXT DEFAULT '', +;; keylock TEXT, +;; params TEXT, +;; creation_time TIMESTAMP DEFAULT (strftime('%s','now')), +;; execution_time TIMESTAMP); ;; register a task (define (tasks:add dbstruct action owner target runname testpatt params) (db:with-db @@ -645,10 +656,27 @@ ;; WHERE ;; state IN " statesstr " AND ;; action IN " actionsstr " ORDER BY creation_time DESC;")) res)))) + +(define (tasks:get-last dbstruct target runname) + (let ((res #f)) + (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id . rem) + (set! res (apply vector id rem))) + db + (conc "SELECT id,action,owner,state,target,name,testpatt,keylock,params,creation_time,execution_time + FROM tasks_queue + WHERE + target = ? AND name =? + ORDER BY creation_time DESC LIMIT 1;") + target runname) + res)))) ;; remove tasks given by a string of numbers comma separated (define (tasks:remove-queue-entries dbstruct task-ids) (db:with-db dbstruct #f #t