Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -33,10 +33,11 @@ (define *configinfo* #f) (define *configdat* #f) (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) +(define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *verbosity* 1) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* #f) ;; if set up for server communication this will hold Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -78,11 +78,11 @@ (exit 1))) (define *db* (open-db)) ;; HACK ALERT: this is a hack, please fix. -(define *read-only* (file-read-access? (conc *toppath* "/megatest.db"))) +(define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) ;; (server:client-setup *db*) (define toplevel #f) (define dlg #f) (define max-test-num 0) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -38,11 +38,11 @@ (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) - (handler (make-busy-timeout 36000))) + (handler (make-busy-timeout 3600))) ;; 136000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (db:initialize db)) db)) @@ -213,11 +213,11 @@ tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', CONSTRAINT test_data UNIQUE (test_id,category,variable));") - (print "WARNING: Table test_data and test_meta where recreated. Please do megatest -update-meta") + (print "WARNING: Table test_data and test_meta were recreated. Please do megatest -update-meta") (patch-db)) ((< mver 1.27) (db:set-var db "MEGATEST_VERSION" 1.27) (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';") (patch-db)) @@ -445,11 +445,13 @@ db "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;" run-id test-name (item-list->path itemdat)) (for-each (lambda (id) (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" id) - (thread-sleep! 0.1)) ;; give others access to the db + (thread-sleep! 0.1) ;; give others access to the db + (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" id) + (thread-sleep! 0.1)) ;; give others access to the db ids))) ;;"DELETE FROM test_steps WHERE test_id in (SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?);" ;; (define (db:delete-test-records db test-id) @@ -550,12 +552,14 @@ db "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" rundir run-id test-name item-path)) (define (db:test-set-log! db run-id test-name item-path logf) - (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" - logf run-id test-name item-path)) + (if (string? logf) + (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" + logf run-id test-name item-path) + (debug:print 0 "ERROR: db:test-set-log! called with non-string log file name " logf))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== @@ -806,24 +810,24 @@ "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) (reverse res))) (define (db:load-test-data db run-id test-name itemdat) (let* ((item-path (item-list->path itemdat)) - (testdat (db:get-test-info db run-id test-name item-path)) + (testdat (rdb:get-test-info db run-id test-name item-path)) (test-id (if testdat (db:test-get-id testdat) #f))) ;; (debug:print 1 "Enter records to insert in the test_data table, seven fields, comma separated per line") (debug:print 4 "itemdat: " itemdat ", test-name: " test-name ", test-id: " test-id) (if test-id (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) - (db:csv->test-data db test-id lin) + (rdb:csv->test-data db test-id lin) (loop (read-line)))))) ;; roll up the current results. ;; FIXME: Add the status to - (db:test-data-rollup db test-id #f))) + (rdb:test-data-rollup db test-id #f))) ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. @@ -1189,12 +1193,11 @@ (define (rdb:test-set-log! db run-id test-name item-path logf) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:test-set-log! host port) - run-id test-name item-path logf)) + ((rpc:procedure 'rdb:test-set-log! host port) run-id test-name item-path logf)) (db:test-set-log! db run-id test-name item-path logf))) (define (rdb:get-runs db runnamepatt numruns startrunoffset keypatts) (if *runremote* (let ((host (vector-ref *runremote* 0)) @@ -1311,5 +1314,12 @@ (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rdb:delete-test-records host port) test-id)) (db:delete-test-records db test-id))) + +(define (rdb:test-data-rollup db test-id status) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:test-data-rollup host port) test-id status)) + (db:test-data-rollup db test-id status))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -44,11 +44,12 @@ (and logpro (eq? exitcode 2)))) (define (launch:execute encoded-cmd) (let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd))))) (setenv "MT_CMDINFO" encoded-cmd) - (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) + (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) + ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) @@ -298,11 +299,11 @@ (mutex-lock! m) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (let* ((item-path (item-list->path itemdat)) - (testinfo (db:get-test-info db run-id test-name item-path))) + (testinfo (rdb:get-test-info db run-id test-name item-path))) (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) (begin (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) (test-set-status! db run-id test-name (if kill-job? "KILLED" "COMPLETED") @@ -439,27 +440,30 @@ (diskspace (config-lookup test-conf "requirements" "diskspace")) (memory (config-lookup test-conf "requirements" "memory")) (hosts (config-lookup *configdat* "jobtools" "workhosts")) (remote-megatest (config-lookup *configdat* "setup" "executable")) ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to - ;; allow running from dashboard + ;; allow running from dashboard. Extract the path + ;; from the called megatest and convert dashboard + ;; or dboard to megatest (local-megatest (let* ((lm (car (argv))) (dir (pathname-directory lm)) (exe (pathname-strip-directory lm))) (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 + (test-sig (conc test-name ":" (item-list->path itemdat))) ;; test-path is the full path including the item-path (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f)) (if hosts (set! hosts (string-split hosts))) + ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) ;; set up the run work area for this test (set! diskpath (get-best-disk *configdat*)) @@ -497,11 +501,10 @@ (if (not useshell)(debug:print 0 "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section")) (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" ""))))) (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) (debug:print 1 "Launching megatest for test " test-name " in " work-area" ...") (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat #f #f) ;; (if launch-results launch-results "FAILED")) - ;; set ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done (debug:print 4 "fullcmd: " fullcmd) (let* ((commonprevvals (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))) (testprevvals (alist->env-vars @@ -518,11 +521,11 @@ print (if useshell '() (cdr fullcmd))))) ;; launcher fullcmd)));; (apply cmd-run-proc-each-line launcher print fullcmd))) ;; (cmd-run->list fullcmd)) (debug:print 2 "Launching completed, updating db") - (debug:print 4 "Launch results: " launch-results) + (debug:print 2 "Launch results: " launch-results) (if (not launch-results) (begin (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") (sqlite3:finalize! db) ;; good ole "exit" seems not to work Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -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) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos) ;; (srfi 18) extras) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (uses common)) (declare (uses megatest-version)) @@ -337,12 +337,14 @@ (if (and (args:get-arg "-server") (not (or (args:get-arg "-runall") (args:get-arg "-runtests")))) (let* ((toppath (setup-for-run)) (db (if toppath (open-db) #f))) + (debug:print 0 "INFO: Starting the standalone server") (if db - (server:start db (args:get-arg "-server")) + (let ((th2 (server:start db (args:get-arg "-server")))) + (thread-join! th2)) (debug:print 0 "ERROR: Failed to setup for megatest")))) ;;====================================================================== ;; full run ;;====================================================================== @@ -455,11 +457,11 @@ (if (not (args:get-arg "-server")) (server:client-setup db)) (let* ((itempatt (args:get-arg "-itempatt")) (keys (rdb:get-keys db)) (keynames (map key:get-fieldname keys)) - (paths (db:test-get-paths-matching db keynames target))) + (paths (rdb:test-get-paths-matching db keynames target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call @@ -466,11 +468,11 @@ (general-run-call "-test-paths" "Get paths to tests" (lambda (db target runname keys keynames keyvallst) (let* ((itempatt (args:get-arg "-itempatt")) - (paths (db:test-get-paths-matching db keynames target))) + (paths (rdb:test-get-paths-matching db keynames target))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -614,17 +616,18 @@ (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (if (args:get-arg "-load-test-data") + ;; has sub commands that are rdb: (db:load-test-data db run-id test-name itemdat)) (if (args:get-arg "-setlog") - (test-set-log! db run-id test-name itemdat (args:get-arg "-setlog"))) + (rdb:test-set-log! db run-id test-name itemdat (args:get-arg "-setlog"))) (if (args:get-arg "-set-toplog") - (test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) + (rdb:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") - (tests:summarize-items db run-id test-name #t)) ;; do force here + (rdb:tests:summarize-items db run-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) (begin (debug:print 0 "ERROR: nothing specified to run!") (sqlite3:finalize! db) @@ -664,11 +667,11 @@ (debug:print 2 "INFO: running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) - (test-set-log! db run-id test-name itemdat htmllogfile))) + (rdb:test-set-log! db run-id test-name itemdat htmllogfile))) (rdb:teststep-set-status! db run-id test-name stepname "end" exitstat itemdat (args:get-arg "-m") logfile) (sqlite3:finalize! db) (if (not (eq? exitstat 0)) (exit 254)) ;; (exit exitstat) doesn't work?!? ;; open the db @@ -694,11 +697,11 @@ (not status))) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) (sqlite3:finalize! db) (exit 6))) - (test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m") otherdata))) + (rtests:test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m") otherdata))) (sqlite3:finalize! db) (set! *didsomething* #t)))) (if (args:get-arg "-showkeys") (let ((db #f) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -8,11 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18)) (import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) @@ -392,11 +392,15 @@ (setenv "MT_RUNNAME" runname) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated - (runs:update-test_meta db test-name test-conf) + ;; Yes, another use of a global for caching. Need a better way? + (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) + (begin + (hash-table-set! *test-meta-updated* test-name #t) + (runs:update-test_meta db test-name test-conf))) ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique (testdat (db:get-test-info db run-id test-name item-path))) @@ -449,11 +453,12 @@ (else (set! runflag #f))) (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat) - "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) "\" or -force to override")) + "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) + "\" or -force to override")) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. (if (not (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") @@ -571,11 +576,12 @@ ;; this wrapper is used to reduce the replication of code (define (general-run-call switchname action-desc proc) (let ((runname (args:get-arg ":runname")) (target (if (args:get-arg "-target") (args:get-arg "-target") - (args:get-arg "-reqtarg")))) + (args:get-arg "-reqtarg"))) + (th1 #f)) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) @@ -587,12 +593,15 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) + (if (args:get-arg "-server") + (server:start db (args:get-arg "-server")) + (if (not (or (args:get-arg "-runall") + (args:get-arg "-runtests"))) + (set! th1 (server:client-setup db)))) (set! keys (rdb:get-keys db)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #f environ-patt: #f))) @@ -611,10 +620,11 @@ ;; Extract out stuff needed in most or many calls ;; here then call proc (let* ((keynames (map key:get-fieldname keys)) (keyvallst (keys->vallist keys #t))) (proc db target runname keys keynames keyvallst))) + (if th1 (thread-join! th1)) (sqlite3:finalize! db) (set! *didsomething* #t)))))) ;;====================================================================== ;; Rollup runs Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -82,11 +82,11 @@ (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state))) (rpc:publish-procedure! 'rdb:csv->test-data (lambda (test-id csvdata) - (db:csv->data db test-id csvdata))) + (db:csv->test-data db test-id csvdata))) (rpc:publish-procedure! 'rdb:roll-up-pass-fail-counts (lambda (run-id test-name item-path status) (db:roll-up-pass-fail-counts db run-id test-name item-path status))) @@ -198,17 +198,34 @@ (rpc:publish-procedure! 'rtests:register-test (lambda (run-id test-name item-path) (tests:register-test db run-id test-name item-path))) + (rpc:publish-procedure! + 'rdb:test-data-rollup + (lambda (test-id status) + (db:test-data-rollup db test-id status))) + + (rpc:publish-procedure! + 'rtests:test-set-status! + (lambda (run-id test-name state status itemdat-or-path comment dat) + (test-set-status! db run-id test-name state status itemdat-or-path comment dat))) + + ;;====================================================================== + ;; end of publish-procedure section + ;;====================================================================== + (set! *rpc:listener* rpc:listener) (on-exit (lambda () (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port) (sqlite3:finalize! db))) (thread-start! th1) (thread-start! th2) - (thread-join! th2))) ;; rpc:server))) + ;; (thread-join! th2) + ;; return th2 for the calling process to do a join with + th2 + )) ;; rpc:server))) (define (server:find-free-port-and-open port) (handle-exceptions exn (begin Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -387,5 +387,12 @@ (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rtests:register-test host port) run-id test-name item-path)) (tests:register-test db run-id test-name item-path))) + +(define (rtests:test-set-status! db run-id test-name state status itemdat-or-path comment dat) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rtests:test-set-status! host port) run-id test-name state status itemdat-or-path comment dat)) + (test-set-status! db run-id test-name state status itemdat-or-path comment dat))) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -6,11 +6,11 @@ runall : cd ../;make install mkdir -p /tmp/mt_runs /tmp/mt_links $(BINPATH)/dboard -rows 15 & - $(MEGATEST) -runall -target ubuntu/nfs/none :runname `date +w%V.%u.%H` -m "This is a comment specific to a run" -v + $(MEGATEST) -runall -target ubuntu/nfs/none :runname `date +w%V.%u.%H` -m "This is a comment specific to a run" -v -server - test : csi -b -I .. ../megatest.scm -- -runall -target ubuntu/afs/tmp :runname blah cd ../;make test make runall Index: tests/megatest.config ================================================================== --- tests/megatest.config +++ tests/megatest.config @@ -7,11 +7,11 @@ # exectutable /path/to/megatest max_concurrent_jobs 200 linktree /tmp/mt_links [jobtools] -# useshell yes +useshell yes # ## launcher launches jobs, the job is managed on the target host ## by megatest, comment out launcher to run local # workhosts localhost hermes launcher nbfake # launcher nodanggood Index: utils/mt_ezstep ================================================================== --- utils/mt_ezstep +++ utils/mt_ezstep @@ -27,14 +27,18 @@ # source the environment from the previous step if it exists # if a logpro file exists then use it otherwise just run the command, nb// was using 2>&1 if [ -e ${stepname}.logpro ];then - $command 2>&1| logpro ${stepname}.logpro ${stepname}.html &> ${stepname}.log + # could do: + $command 2>&1| tee ${stepname}.log | logpro ${stepname}.logpro ${stepname}.html &> /dev/null + logprostatus=$? + # $command 2>&1| logpro ${stepname}.logpro ${stepname}.html &> ${stepname}.log + # allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) runstatus=${allstatus[0]} - logprostatus=${allstatus[1]} + # logprostatus=${allstatus[1]} else $command &> ${stepname}.log runstatus=$? logprostatus=$runstatus fi