Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -904,10 +904,23 @@ "locked")))) ;; semi-failsafe (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 "" newlockval " run number " run-id))) + +(define (db:set-run-status db run-id status) + (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)) + +(define (db:get-run-status db run-id) + (let ((res "n/a")) + (sqlite3:for-each-row + (lambda (status) + (set! res status)) + db + "SELECT status FROM runs WHERE id=?;" + run-id) + res)) (define (db:get-run-ids db) (let ((res '())) (sqlite3:for-each-row (lambda (id) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -38,10 +38,13 @@ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) +;; Disabled help items +;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) +;; from prior runs with same keys (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2012 @@ -56,14 +59,14 @@ -runtests tst1,tst2 ... : run tests -remove-runs : remove the data for a run, requires :runname and -testpatt Optionally use :state and :status -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs -rerun FAIL,WARN... : force re-run for tests with specificed status(s) - -rollup : (currently disabled) fill run (set by :runname) with latest test(s) - from prior runs with same keys -lock : lock run specified by target and runname -unlock : unlock run specified by target and runname + -set-run-status status : sets status for run to status, requires -target and :runname + -get-run-status : gets status for run specified by target and runname -run-wait : wait on run specified by target and runname Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig @@ -190,10 +193,11 @@ "-extract-ods" "-pathmod" "-env2file" "-setvars" "-set-state-status" + "-set-run-status" "-debug" ;; for *verbosity* > 2 "-gen-megatest-test" "-override-timeout" "-test-files" ;; -test-paths is for listing all "-load" ;; load and exectute a scheme file @@ -224,10 +228,12 @@ "-list-targets" "-list-db-targets" "-show-runconfig" "-show-config" "-show-cmdinfo" + "-get-run-status" + ;; queries "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests "-remove-runs" @@ -378,34 +384,10 @@ (server:ensure-running) (client:launch)) (else ;; (fs) (set! *transport-type* 'fs) (set! *megatest-db* (open-db)))))))))) -;; (cond -;; ;; command line overrides other mechanisms -;; (transport-from-cmdln -;; (if (equal? transport-from-cmdln "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; ;; cmdinfo is second priority -;; (transport-from-cmdinfo -;; (if (equal? transport-from-cmdinfo "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; ;; config file is next highest priority for determinining transport -;; (transport-from-config -;; (if (equal? transport-from-config "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; (else -;; (set! *transport-type* 'fs))))))))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) (let ((tl (setup-for-run))) (if tl @@ -485,33 +467,38 @@ (read-config "runconfigs.config" #f #t sections: sections)))) data)) (if (args:get-arg "-show-runconfig") - (let ((data (full-runconfigs-read))) - ;; keep this one local - (cond - ((not (args:get-arg "-dumpmode")) - (pp (hash-table->alist data))) - ((string=? (args:get-arg "-dumpmode") "json") + (let ((tl (setup-for-run))) + (push-directory *toppath*) + (let ((data (full-runconfigs-read))) + ;; keep this one local + (cond + ((not (args:get-arg "-dumpmode")) + (pp (hash-table->alist data))) + ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) - (else - (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) - (set! *didsomething* #t))) + (else + (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (set! *didsomething* #t)) + (pop-directory))) (if (args:get-arg "-show-config") (let ((tl (setup-for-run)) (data *configdat*)) ;; (read-config "megatest.config" #f #t))) + (push-directory *toppath*) ;; keep this one local (cond ((not (args:get-arg "-dumpmode")) (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) (else (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) - (set! *didsomething* #t))) + (set! *didsomething* #t) + (pop-directory))) (if (args:get-arg "-show-cmdinfo") (if (getenv "MT_CMDINFO") (let ((data (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))) (if (equal? (args:get-arg "-dumpmode") "json") @@ -566,10 +553,31 @@ (general-run-call "-set-state-status" "set state and status" (lambda (target runname keys keyvals) (operate-on 'set-state-status)))) + +(if (or (args:get-arg "-set-run-status") + (args:get-arg "-get-run-status")) + (general-run-call + "-set-run-status" + "set run status" + (lambda (target runname keys keyvals) + (let* ((runsdat (cdb:remote-run db:get-runs-by-patt #f keys runname (or (args:get-arg "-target") + (args:get-arg "-reqtarg")) #f #f)) + (header (vector-ref runsdat 0)) + (rows (vector-ref runsdat 1))) + (if (null? rows) + (begin + (debug:print-info 0 "No matching run found.") + (exit 1)) + (let* ((row (car (vector-ref runsdat 1))) + (run-id (db:get-value-by-header row header "id"))) + (if (args:get-arg "-set-run-status") + (cdb:remote-run db:set-run-status #f run-id (args:get-arg "-set-run-status")) + (print (open-run-close db:get-run-status #f run-id)) + ))))))) ;;====================================================================== ;; Query runs ;;======================================================================