Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -69,11 +69,18 @@ (tasks:add-from-params tdb "run" keys key-params var-params) (print "Launch Run"))) (iup:button "Remove" #:expand "HORIZONTAL" #:action (lambda (obj) - (print "Remove Run"))))) + (print "Remove Run") + (tasks:add-from-params tdb "remove" keys key-params var-params) + )) + (iup:button "Rollup" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (print "Rollup Run") + (tasks:add-from-params tdb "rollup" keys key-params var-params))))) (iup:frame #:title "Misc" (iup:hbox (iup:button "Quit" #:expand "HORIZONTAL" @@ -126,22 +133,23 @@ #:title "Run Controls" (iup:vbox (iup:hbox keyentries othervars) controls (let ((tabtop (iup:tabs - monitors (iup:vbox (let* ((tb (iup:textbox #:expand "HORIZONTAL")) (bt (iup:button "Remove tasks by id" #:action (lambda (obj) (let ((val (iup:attribute tb "VALUE"))) (tasks:remove-queue-entries tdb val))))) (lb (iup:label "(comma separated)"))) (iup:hbox bt tb lb)) - actions)))) - (iup:attribute-set! tabtop "TABTITLE0" "Monitors") - (iup:attribute-set! tabtop "TABTITLE1" "Actions") + actions) + monitors + ))) + (iup:attribute-set! tabtop "TABTITLE0" "Actions") + (iup:attribute-set! tabtop "TABTITLE1" "Monitors") tabtop) ))) ; (iup:frame ; #:title "Monitors" ; monitors) Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -96,10 +96,11 @@ (append targlist (make-list (- numkeys numtarg) "")) targlist))) (map (lambda (key targ) (list (vector-ref key 0) targ)) keys targtweaked))) + ;;====================================================================== ;; key <=> args routines ;;====================================================================== @@ -109,11 +110,16 @@ ;; withkey => (:key1 val1 :key2 val2 :key3 val3 ...) (define (keys->vallist keys . withkey) ;; ORDERING IS VERY IMPORTANT, KEEP PROPER ORDER HERE! (let* ((keynames (map key:get-fieldname keys)) (argkeys (map (lambda (k)(conc ":" k)) keynames)) (withkey (not (null? withkey))) - (newremargs (args:get-args (cons "blah" remargs) argkeys '() args:arg-hash 0))) ;; the cons blah works around a bug in args [args assumes ("calling-prog-name" .... ) ] + (newremargs (args:get-args + (cons "blah" remargs) ;; the cons blah works around a bug in args [args assumes ("calling-prog-name" .... ) ] + argkeys + '() + args:arg-hash + 0))) ;;(debug:print 0 "remargs: " remargs " newremargs: " newremargs) (apply append (map (lambda (x) (let ((val (args:get-arg x))) ;; (debug:print 0 "x: " x " val: " val) (if (not val) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -369,11 +369,11 @@ ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to ;; allow running from dashboard (local-megatest (let* ((lm (car (argv))) (dir (pathname-directory lm)) (exe (pathname-strip-directory lm))) - (conc dir "/" + (conc (if dir (conc dir "/") "") (case (string->symbol exe) ((dboard) "megatest") ((dashboard) "megatest") (else exe))))) (test-sig (conc "=" test-name ":" (item-list->path itemdat) "=")) ;; test-path is the full path including the item-path Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -336,11 +336,15 @@ (if (args:get-arg "-rollup") (general-run-call "-rollup" "rollup tests" (lambda (db keys keynames keyvallst) - (runs:rollup-run db keys)))) + (runs:rollup-run db + keys + (keys->alist keys "na") + (args:get-arg ":runname") + user)))) ;;====================================================================== ;; Extract a spreadsheet from the runs database ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -779,10 +779,11 @@ ;; based code. ;;====================================================================== ;; register a test run with the db (define (runs:register-run db keys keyvallst runname state status user) + (debug:print 3 "runs:register-run, keys: " keys " keyvallst: " keyvallst " runname: " runname " state: " state " status: " status " user: " user) (let* ((keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (keyvals (map cadr keyvallst)) @@ -1217,14 +1218,16 @@ (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) ;; read configs with tricks turned off (i.e. no system) (test-conf (if testexists (read-config test-configf #f #f)(make-hash-table)))) (runs:update-test_meta db test-name test-conf))) test-names))) - + ;; This could probably be refactored into one complex query ... -(define (runs:rollup-run db keys) - (let* ((new-run-id (register-run db keys)) +(define (runs:rollup-run db keys keyvallst runname user) ;; was target, now keyvallst + (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user) + (let* (; (keyvalllst (keys:target->keyval keys target)) + (new-run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) (prev-tests (test:get-matching-previous-test-run-records db new-run-id "%" "%")) (curr-tests (db-get-tests-for-run db new-run-id "%" "%" '() '())) (curr-tests-hash (make-hash-table))) (db:update-run-event_time db new-run-id) ;; index the already saved tests by testname and itempath in curr-tests-hash Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -195,11 +195,11 @@ (loop (+ count 1) next-touch))))))) (define (tasks:process-queue db tdb) (let* ((task (tasks:snag-a-task tdb)) (action (if task (tasks:task-get-action task) #f))) - (print "tasks:process-queue task: " task) + (if action (print "tasks:process-queue task: " task)) (if action (case (string->symbol action) ((run) (tasks:start-run db tdb task)) ((remove) (tasks:remove-runs db tdb task)) ((lock) (tasks:lock-runs db tdb task)) @@ -273,10 +273,17 @@ (define (tasks:set-state tdb task-id state) (sqlite3:execute tdb "UPDATE tasks_queue SET state=? WHERE id=?;" state task-id)) +;;====================================================================== +;; The routines to process tasks +;;====================================================================== + +;; NOTE: It might be good to add one more layer of checking to ensure +;; that no task gets run in parallel. + (define (tasks:start-run db tdb task) (let ((flags (make-hash-table))) (hash-table-set! flags "-rerun" "NOT_STARTED") (print "Starting run " task) ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY @@ -286,5 +293,19 @@ (tasks:task-get-test task) (tasks:task-get-item task) (tasks:task-get-owner task) flags) (tasks:set-state tdb (tasks:task-get-id task) "waiting"))) + +(define (tasks:rollup-runs db tdb task) + (let* ((flags (make-hash-table)) + (keys (db:get-keys db)) + (keyvallst (keys:target->keyval keys (tasks:task-get-target task)))) + ;; (hash-table-set! flags "-rerun" "NOT_STARTED") + (print "Starting rollup " task) + ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY + (runs:rollup-run db + keys + keyvallst + (tasks:task-get-name task) + (tasks:task-get-owner task)) + (tasks:set-state tdb (tasks:task-get-id task) "waiting")))