@@ -8,11 +8,11 @@ ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") -(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client) ;; (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client directory-utils) ;; (srfi 18) extras) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) ;; (use zmq) @@ -44,10 +44,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 @@ -62,14 +65,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 @@ -113,10 +116,11 @@ -show-runconfig : dump the internal representation of the runconfigs.config file -dumpmode json : dump in json format instead of sexpr -show-cmdinfo : dump the command info for a test (run in test environment) Misc + -start-dir path : switch to this directory before running megatest -rebuild-db : bring the database schema up to date -cleanup-db : remove any orphan records, vacuum the db -update-meta : update the tests metadata for all tests -env2file fname : write the environment to fname.csh and fname.sh -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are @@ -186,18 +190,20 @@ ":value" ":expected" ":tol" ":units" ;; misc + "-start-dir" "-server" "-stop-server" "-port" "-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 @@ -229,10 +235,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" @@ -256,10 +264,17 @@ (if (args:get-arg "-h") (begin (print help) (exit))) + +(if (args:get-arg "-start-dir") + (if (file-exists? (args:get-arg "-start-dir")) + (change-directory (args:get-arg "-start-dir")) + (begin + (debug:print 0 "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) (if (args:get-arg "-version") (begin (print megatest-version) (exit))) @@ -453,33 +468,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") @@ -534,10 +554,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") msg: (args:get-arg "-m")) + (print (open-run-close db:get-run-status #f run-id)) + ))))))) ;;====================================================================== ;; Query runs ;;======================================================================