Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -3,11 +3,11 @@ CSCOPTS= SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ - process.scm runs.scm tasks.scm tests.scm + process.scm runs.scm tasks.scm tests.scm GUISRCF = dashboard.scm dashboard-tests.scm dashboard-guimonitor.scm dashboard-main.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -37,11 +37,10 @@ (define *waiting-queue* (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 (define (get-with-default val default) (let ((val (args:get-arg val))) (if val val default))) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -247,11 +247,11 @@ ;;====================================================================== ;; ;;====================================================================== (define (examine-test db test-id) ;; run-id run-key origtest) - (let* ((testdat (rdb:get-test-data-by-id db test-id)) + (let* ((testdat (db:get-test-data-by-id db test-id)) (run-id (if testdat (db:test-get-run_id testdat) #f)) (keydat (if testdat (keys:get-key-val-pairs db run-id) #f)) (rundat (if testdat (db:get-run-info db run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-row rundat) (db:get-header rundat) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -11,13 +11,10 @@ ;;====================================================================== ;; Database access ;;====================================================================== -(require-extension (srfi 18) extras tcp rpc) -(import (prefix rpc rpc:)) - (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml) (import (prefix sqlite3 sqlite3:)) (declare (unit db)) (declare (uses common)) @@ -25,11 +22,10 @@ (declare (uses ods)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") -(include "run_records.scm") (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (configdat (car *configinfo*)) (dbexists (file-exists? dbpath)) @@ -89,11 +85,10 @@ run_duration INTEGER DEFAULT 0, comment TEXT DEFAULT '', event_time TIMESTAMP, fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, - archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) );") (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname);") (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps @@ -135,11 +130,10 @@ type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") ;; Must do this *after* running patch db !! No more. (db:set-var db "MEGATEST_VERSION" megatest-version) )) - (server:client-setup db) db)) ;;====================================================================== ;; TODO: ;; put deltas into an assoc list with version numbers @@ -216,14 +210,11 @@ (db:set-var db "MEGATEST_VERSION" 1.29) (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';") (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';")) ((< mver 1.36) (db:set-var db "MEGATEST_VERSION" 1.36) - (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';")) - ((< mver 1.37) - (db:set-var db "MEGATEST_VERSION" 1.37) - (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;")) + (sqlite3:execute db "ALTER TABLER test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';")) ((< mver megatest-version) (db:set-var db "MEGATEST_VERSION" megatest-version)))))) ;;====================================================================== ;; meta get and set vars @@ -421,14 +412,10 @@ (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))) -(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) - (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" - state status run-id test-name item-path)) - (define (db:get-count-tests-running db) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) @@ -481,31 +468,24 @@ "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;" test-id) res)) -(define (db:test-set-comment db run-id test-name item-path comment) +(define (db:test-set-comment db run-id testname item-path comment) (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" - comment run-id test-name item-path)) + comment run-id testname item-path)) ;; -(define (db:test-set-rundir! db run-id test-name item-path rundir) +(define (db:test-set-rundir! db run-id testname item-path rundir) (sqlite3:execute 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)) - -;;====================================================================== -;; Misc. test related queries -;;====================================================================== - + rundir run-id testname item-path)) + +;; Misc. test related queries (define (db:test-get-paths-matching db keynames target) (let* ((res '()) (itempatt (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "%")) (testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) @@ -527,101 +507,10 @@ (set! res (cons p res))) db qrystr) res)) -(define (db:test-get-test-records-matching db keynames target) - (let* ((res '()) - (itempatt (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "%")) - (testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) - (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) - (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) - (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) - (keystr (string-intersperse - (map (lambda (key val) - (conc "r." key " like '" val "'")) - keynames - (string-split target "/")) - " AND ")) - (qrystr (conc "SELECT - t.id - t.run_id - t.testname - t.host - t.cpuload - t.diskfree - t.uname - t.rundir - t.shortdir - t.item_path - t.state - t.status - t.attemptnum - t.final_logf - t.logdat - t.run_duratio - t.comment - t.event_time - t.fail_count - t.pass_count - t.archived - - - - FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE " - keystr " AND r.runname LIKE '" runname "' AND item_path LIKE '" itempatt "' AND testname LIKE '" - testpatt "' AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt - "'ORDER BY t.event_time ASC;"))) - (debug:print 3 "qrystr: " qrystr) - (sqlite3:for-each-row - (lambda (p) - (set! res (cons p res))) - db - qrystr) - res)) - -(define (db:test-update-meta-info db run-id test-name item-path minutes cpuload diskfree tmpfree) - (if (not item-path) - (begin (debug:print 0 "WARNING: ITEMPATH not set.") - (set! item-path ""))) - (sqlite3:execute - db - "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');" - cpuload - diskfree - minutes - run-id - test-name - item-path)) - -(define (db:roll-up-pass-fail-counts db run-id test-name item-path status) - (if (and (not (equal? item-path "")) - (or (equal? status "PASS") - (equal? status "WARN") - (equal? status "FAIL") - (equal? status "WAIVED") - (equal? status "RUNNING"))) - (begin - (sqlite3:execute - db - "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'), - pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED')) - WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name run-id test-name run-id test-name) - (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING - (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name) - (sqlite3:execute - db - "UPDATE tests - SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN - 'RUNNING' - ELSE 'COMPLETED' END, - status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END - WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name run-id test-name))))) - ;;====================================================================== ;; Tests meta data ;;====================================================================== @@ -903,29 +792,10 @@ ;; if the test is not found then clearly the waiton is not met... (if (not ever-seen)(set! result (cons waitontest-name result))))) waitons) (delete-duplicates result)))) -(define (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile) - (debug:print 4 "run-id: " run-id " test-name: " test-name) - (let* ((state (check-valid-items "state" state-in)) - (status (check-valid-items "status" status-in)) - (testdat (db:get-test-info db run-id test-name item-path))) - (debug:print 5 "testdat: " testdat) - (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works. - (or (not state)(not status))) - (debug:print 0 "WARNING: Invalid " (if status "status" "state") - " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (if testdat - (let ((test-id (test:get-id testdat))) - ;; FIXME - this should not update the logfile unless it is specified. - (sqlite3:execute db - "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,strftime('%s','now'),?,?);" - test-id teststep-name state-in status-in (if comment comment "") (if logfile logfile "")) - #t) ;; fake out a #t - could be execute is returning something complicated - (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db")))) - ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== ;; runspatt is a comma delimited list of run patterns @@ -1046,84 +916,5 @@ results) ;; brutal clean up (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") - - -;;====================================================================== -;; REMOTE DB ACCESS VIA RPC -;;====================================================================== - -(define (rdb:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:set-tests-state-status host port) - run-id testnames currstate currstatus newstate newstatus)) - (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus))) - -(define (rdb:teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile) - (let ((item-path (item-list->path itemdat))) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:teststep-set-status! host port) - run-id test-name teststep-name state-in status-in item-path comment logfile)) - (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile)))) - -(define (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree) - (let ((item-path (item-list->path itemdat))) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:test-update-meta-info host port) - run-id test-name item-path minutes cpuload diskfree tmpfree)) - (db:test-update-meta-info db run-id test-name item-path minutes cpuload diskfree tmpfree)))) - -(define (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:test-set-state-status-by-run-id-testname host port) - run-id test-name item-path status state)) - (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state))) - -(define (rdb:csv->test-data db test-id csvdata) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:csv->test-data host port) - test-id csvdata)) - (db:csv->test-data db test-id csvdata))) - -(define (rdb:roll-up-pass-fail-counts db run-id test-name item-path status) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:roll-up-pass-fail-counts host port) - run-id test-name item-path status)) - (db:roll-up-pass-fail-counts db run-id test-name item-path status))) - -(define (rdb:test-set-comment db run-id test-name item-path comment) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:test-set-comment host port) - run-id test-name item-path comment)) - (db:test-set-comment db run-id test-name item-path comment))) - -(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 'rpc: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-test-data-by-id db test-id) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rpc:get-test-data-by-id host port) - test-id)) - (db:get-test-data-by-id db test-id))) Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -16,30 +16,25 @@ (declare (unit items)) (declare (uses common)) (include "common_records.scm") -;; Puts out all combinations -(define (process-itemlist hierdepth curritemkey itemlist) - (let ((res '())) - (if (not hierdepth) - (set! hierdepth (length itemlist))) - (let loop ((hed (car itemlist)) - (tal (cdr itemlist))) - (if (null? tal) - (for-each (lambda (item) - (if (> (length curritemkey) (- hierdepth 2)) - (set! res (append res (list (append curritemkey (list (list (car hed) item)))))))) - (cadr hed)) - (begin - (for-each (lambda (item) - (set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal)))) - (cadr hed)) - (loop (car tal)(cdr tal))))) - res)) - -;; Puts out all combinations +;; Mostly worked = puts out all combinations? +(define (process-itemlist-try1 curritemkey itemlist) + (let loop ((hed (car itemlist)) + (tal (cdr itemlist))) + (if (null? tal) + (for-each (lambda (item) + (debug:print 6 "curritemkey: " (append curritemkey (list item)))) + (cadr hed)) + (begin + (for-each (lambda (item) + (process-itemlist (append curritemkey (list item)) tal)) + (cadr hed)) + (loop (car tal)(cdr tal)))))) + +;; Mostly worked = puts out all combinations? (define (process-itemlist hierdepth curritemkey itemlist) (let ((res '())) (if (not hierdepth) (set! hierdepth (length itemlist))) (let loop ((hed (car itemlist)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -179,11 +179,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - (rdb:teststep-set-status! db run-id test-name stepname "start" "-" itemdat #f #f) + (teststep-set-status! db run-id test-name stepname "start" "-" itemdat #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) @@ -194,11 +194,11 @@ (if (eq? pid-val 0) (begin (thread-sleep! 2) (processloop (+ i 1)))) )) - (rdb:teststep-set-status! db run-id test-name stepname "end" (vector-ref exit-info 2) itemdat #f (if logpro-used (conc stepname ".html") "")) + (teststep-set-status! db run-id test-name stepname "end" (vector-ref exit-info 2) itemdat #f (if logpro-used (conc stepname ".html") "")) (if logpro-used (test-set-log! db run-id test-name itemdat (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) @@ -247,11 +247,11 @@ (diskfree (get-df (current-directory))) (tmpfree (get-df "/tmp"))) (if (not cpuload) (begin (debug:print 0 "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) (set! kill-job? (test-get-kill-request db run-id test-name itemdat)) - (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree) + (test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree) (if kill-job? (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.37) +(define megatest-version 1.36) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -17,11 +17,10 @@ (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses runs)) (declare (uses launch)) -(declare (uses server)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -90,14 +89,10 @@ prior runs with same keys -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 overwritten by values set in config files. - -archive : archive tests, use -target, :runname, -itempatt and -testpatt - -server -|hostname : start the server (reduces contention on megatest.db), use - - to automatically figure out hostname - Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html will clear the field if no rundir/testname/itempath/logfile if it contains forward slashes the path will be converted @@ -152,11 +147,10 @@ ":value" ":expected" ":tol" ":units" ;; misc - "-server" "-extract-ods" "-pathmod" "-env2file" "-setvars" "-debug" ;; for *verbosity* > 2 @@ -168,12 +162,10 @@ "-test-status" "-set-values" "-load-test-data" "-summarize-items" "-gui" - ;; misc - "-archive" ;; queries "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests "-remove-runs" @@ -180,11 +172,10 @@ "-keepgoing" "-usequeue" "-rebuild-db" "-rollup" "-update-meta" - "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) args:arg-hash 0)) @@ -384,20 +375,10 @@ (args:get-arg "-itempatt") user (make-hash-table))))) ;;====================================================================== -;; Start the server -;;====================================================================== -(if (args:get-arg "-server") - (let* ((toppath (setup-for-run)) - (db (if toppath (open-db) #f))) - (if db - (server:start db (args:get-arg "-server")) - (debug:print 0 "ERROR: Failed to setup for megatest")))) - -;;;====================================================================== ;; Rollup into a run ;;====================================================================== (if (args:get-arg "-rollup") (general-run-call "-rollup" @@ -410,11 +391,11 @@ user)))) ;;====================================================================== ;; Get paths to tests ;;====================================================================== -;; Get test paths matching target, runname, testpatt, and itempatt +;; run all tests are are Not COMPLETED and PASS or CHECK (if (args:get-arg "-test-paths") ;; if we are in a test use the MT_CMDINFO data (if (getenv "MT_CMDINFO") (let* ((startingdir (current-directory)) (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) @@ -435,58 +416,10 @@ (exit 1))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths, exiting") (exit 1))) - (set! db (open-db)) - (let* ((itempatt (args:get-arg "-itempatt")) - (keys (db-get-keys db)) - (keynames (map key:get-fieldname keys)) - (paths (db:test-get-paths-matching db keynames target))) - (set! *didsomething* #t) - (for-each (lambda (path) - (print path)) - paths))) - ;; else do a general-run-call - (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))) - (for-each (lambda (path) - (print path)) - paths)))))) - -;;====================================================================== -;; Archive tests -;;====================================================================== -;; Archive tests matching target, runname, testpatt, and itempatt -(if (args:get-arg "-archive") - ;; if we are in a test use the MT_CMDINFO data - (if (getenv "MT_CMDINFO") - (let* ((startingdir (current-directory)) - (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) - (testpath (assoc/default 'testpath cmdinfo)) - (test-name (assoc/default 'test-name cmdinfo)) - (runscript (assoc/default 'runscript cmdinfo)) - (db-host (assoc/default 'db-host cmdinfo)) - (run-id (assoc/default 'run-id cmdinfo)) - (itemdat (assoc/default 'itemdat cmdinfo)) - (db #f) - (state (args:get-arg ":state")) - (status (args:get-arg ":status")) - (target (args:get-arg "-target"))) - (change-directory testpath) - (if (not target) - (begin - (debug:print 0 "ERROR: -target is required.") - (exit 1))) - (if (not (setup-for-run)) - (begin - (debug:print 0 "Failed to setup, giving up on -archive, exiting") - (exit 1))) (set! db (open-db)) (let* ((itempatt (args:get-arg "-itempatt")) (keys (db-get-keys db)) (keynames (map key:get-fieldname keys)) (paths (db:test-get-paths-matching db keynames target))) @@ -556,11 +489,11 @@ (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (and state status) - (rdb:teststep-set-status! db run-id test-name step state status itemdat (args:get-arg "-m") logfile) + (teststep-set-status! db run-id test-name step state status itemdat (args:get-arg "-m") logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6))) (sqlite3:finalize! db) (set! *didsomething* #t)))) @@ -619,11 +552,11 @@ ((zsh bash sh ash) "2>&1 >"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test - (rdb:teststep-set-status! db run-id test-name stepname "start" "n/a" itemdat (args:get-arg "-m") logfile) + (teststep-set-status! db run-id test-name stepname "start" "n/a" itemdat (args:get-arg "-m") logfile) ;; close the db (sqlite3:finalize! db) ;; run the test step (debug:print 2 "INFO: Running \"" fullcmd "\"") (change-directory startingdir) @@ -641,11 +574,11 @@ (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:teststep-set-status! db run-id test-name stepname "end" exitstat itemdat (args:get-arg "-m") logfile) + (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 ;; mark the end of the test Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -17,11 +17,10 @@ (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) -(declare (uses server)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -211,11 +210,11 @@ ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. (db:delete-tests-in-state db run-id "NOT_STARTED") - (rdb:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) ;; now add non-directly referenced dependencies (i.e. waiton) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc @@ -410,13 +409,10 @@ (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))) (if (not testdat) (begin - ;; ensure that the path exists before registering the test - ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... - ;; (system (conc "mkdir -p " new-test-path)) (register-test db run-id test-name item-path) (set! testdat (db:get-test-info db run-id test-name item-path)))) (change-directory test-path) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -6,25 +6,12 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. -(require-extension (srfi 18) extras tcp rpc) -(import (prefix rpc rpc:)) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69) -;; (use hostinfo) -(import (prefix sqlite3 sqlite3:)) - (declare (unit server)) -(declare (uses common)) -(declare (uses db)) - -(include "common_records.scm") -(include "db_records.scm") - ;; procstr is the name of the procedure to be called as a string (define (server:autoremote procstr params) (handle-exceptions exn (begin @@ -32,84 +19,23 @@ (apply (eval (string->symbol proc)) params)) (if *runremote* (apply (eval (string->symbol (conc "remote:" procstr))) params) (eval (string->symbol procstr) params)))) -(define (server:start db hostn) +(define (server:start db) (debug:print 0 "Attempting to start the server ...") - (let* ((rpc:listener (server:find-free-port-and-open (rpc:default-server-port))) - (th1 (make-thread - (cute (rpc:make-server rpc:listener) "rpc:server") - 'rpc:server)) - (hostname (if (string=? "-" hostn) - (get-host-name) - hostn)) - (ipaddrstr (if (string=? "-" hostn) - (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") - #f)) - (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" (rpc:default-server-port)))) - (db:set-var db "SERVER" host:port) + (let* ((rpc:listener (server:find-free-port-and-open (rpc:default-server-port))) + (th1 (make-thread + (cute (rpc:make-server rpc:listener) "rpc:server") + 'rpc:server))) + (db:set-var db "SERVER" (conc (get-host-name) ":" (rpc:default-server-port))) (rpc:publish-procedure! 'remote:run (lambda (procstr . params) (server:autoremote procstr params))) - - ;;====================================================================== - ;; db specials here - ;;====================================================================== - ;; ** set-tests-state-status - (rpc:publish-procedure! - 'rdb:set-tests-state-status - (lambda (run-id testnames currstate currstatus newstate newstatus) - (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus))) - - (rpc:publish-procedure! - 'rdb:teststep-set-status! - (lambda (run-id test-name teststep-name state-in status-in item-path comment logfile) - (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile))) - - (rpc:publish-procedure! - 'rdb:test-update-meta-info - (lambda (run-id testname item-path minutes cpuload diskfree tmpfree) - (db:test-update-meta-info db run-id testname item-path minutes cpuload diskfree tmpfree))) - - (rpc:publish-procedure! - 'rdb:test-set-state-status-by-run-id-testname - (lambda (run-id test-name item-path status state) - (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))) - - (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))) - - (rpc:publish-procedure! - 'rdb:test-set-comment - (lambda (run-id test-name item-path comment) - (db:test-set-comment db run-id test-name item-path comment))) - - (rpc:publish-procedure! - 'rpc:test-set-log! - (lambda (run-id test-name item-path logf) - (db:test-set-log! db run-id test-name item-path logf))) - - (rpc:publish-procedure! - 'rpc:get-test-data-by-id - (lambda (test-id) - (db:get-test-data-by-id db test-id))) - - (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-join! th1))) ;; rpc:server))) + (set! *rpc:listener* rpc:listener*) + (thread-start! rpc:server))) (define (server:find-free-port-and-open port) (handle-exceptions exn (begin @@ -121,10 +47,6 @@ (define (server:client-setup db) (let* ((hostinfo (db:get-var db "SERVER")) (hostdat (if hostinfo (string-split hostinfo ":"))) (host (if hostinfo (car hostdat))) (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) - (if (and port - (string->number port)) - (debug:print 2 "INFO: Setting up to connect to host " host ":" port)) - (set! *runremote* (if port (vector host (string->number port)) #f)))) - + (set! *runremote* (vector host port)))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -10,10 +10,11 @@ (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") + (define (register-test db run-id test-name item-path) (let ((item-paths (if (equal? item-path "") (list item-path) (list item-path "")))) @@ -108,11 +109,10 @@ results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) -;; (define (test-set-status! db run-id test-name state status itemdat-or-path comment dat) (let* ((real-status status) (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path))) (testdat (db:get-test-info db run-id test-name item-path)) (test-id (if testdat (db:test-get-id testdat) #f)) @@ -135,14 +135,14 @@ (if waived (set! real-status "WAIVED")) (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) - (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-path real-status state)) + (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" + state real-status run-id test-name item-path)) - ;; if status is "AUTO" then call rollup (note, this one modifies data in test - ;; run area, do not rpc it (yet) + ;; if status is "AUTO" then call rollup (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup db test-id status)) ;; add metadata (need to do this way to avoid SQL injection issues) @@ -166,11 +166,11 @@ (dcomment (hash-table-ref/default otherdat ":comment" ""))) (debug:print 4 "category: " category ", variable: " variable ", value: " value ", expected: " expected ", tol: " tol ", units: " units) (if (and value expected tol) ;; all three required - (rdb:csv->test-data db test-id + (db:csv->test-data db test-id (conc category "," variable "," value "," expected "," tol "," @@ -177,21 +177,46 @@ units "," dcomment ",," ;; extra comma for status type )))) ;; need to update the top test record if PASS or FAIL and this is a subtest - (rdb:roll-up-pass-fail-counts db run-id test-name item-path status) - + (if (and (not (equal? item-path "")) + (or (equal? status "PASS") + (equal? status "WARN") + (equal? status "FAIL") + (equal? status "WAIVED") + (equal? status "RUNNING"))) + (begin + (sqlite3:execute + db + "UPDATE tests + SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'), + pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED')) + WHERE run_id=? AND testname=? AND item_path='';" + run-id test-name run-id test-name run-id test-name) + (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING + (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name) + (sqlite3:execute + db + "UPDATE tests + SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN + 'RUNNING' + ELSE 'COMPLETED' END, + status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END + WHERE run_id=? AND testname=? AND item_path='';" + run-id test-name run-id test-name)))) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) - (rdb:test-set-comment db run-id test-name item-path (if waived waived comment))) + (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" + (if waived waived comment) run-id test-name item-path)) )) (define (test-set-log! db run-id test-name itemdat logf) (let ((item-path (item-list->path itemdat))) - (rdb: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))) (define (test-set-toplog! db run-id test-name logf) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" logf run-id test-name)) @@ -344,11 +369,28 @@ ;;====================================================================== ;; test steps ;;====================================================================== -;; teststep-set-status! used to be here +(define (teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile) + (debug:print 4 "run-id: " run-id " test-name: " test-name) + (let* ((state (check-valid-items "state" state-in)) + (status (check-valid-items "status" status-in)) + (item-path (item-list->path itemdat)) + (testdat (db:get-test-info db run-id test-name item-path))) + (debug:print 5 "testdat: " testdat) + (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works. + (or (not state)(not status))) + (debug:print 0 "WARNING: Invalid " (if status "status" "state") + " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) + (if testdat + (let ((test-id (test:get-id testdat))) + ;; FIXME - this should not update the logfile unless it is specified. + (sqlite3:execute db + "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,strftime('%s','now'),?,?);" + test-id teststep-name state-in status-in (if comment comment "") (if logfile logfile ""))) + (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db")))) (define (test-get-kill-request 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))) (equal? (test:get-state testdat) "KILLREQ"))) @@ -368,14 +410,21 @@ runpath run-id testname item-path))) -;;====================================================================== -;; A R C H I V I N G -;;====================================================================== - -(define (test:archive db test-id) - #f) - -(define (test:archive-tests db keynames target) - #f) +(define (test-update-meta-info db run-id testname itemdat minutes cpuload diskfree tmpfree) + (let ((item-path (item-list->path itemdat))) + (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (set! item-path ""))) + ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) + ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) + ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) + (sqlite3:execute + db + "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');" + cpuload + diskfree + minutes + run-id + testname + item-path))) + Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -3,14 +3,13 @@ BINPATH=$(shell realpath ../bin) MEGATEST=$(BINPATH)/megatest PATH := $(BINPATH):$(PATH) runall : - cd ../;make install - mkdir -p /tmp/mt_runs /tmp/mt_links + cd ../;make install $(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) -keepgoing -runall -target ubuntu/nfs/none :runname `date +w%V.%u.%H` -m "This is a comment specific to a run" -v 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 @@ -4,11 +4,11 @@ datapath TEXT [setup] # exectutable /path/to/megatest max_concurrent_jobs 50 -linktree /tmp/mt_links +linktree /tmp/runs [jobtools] # useshell yes # ## launcher launches jobs, the job is managed on the target host ## by megatest, comment out launcher to run local @@ -39,6 +39,6 @@ ## disks are: ## name host:/path/to/area ## -or- ## name /path/to/area [disks] -1 /tmp/mt_runs +1 /tmp DELETED tests/tests/neverrun/testconfig Index: tests/tests/neverrun/testconfig ================================================================== --- tests/tests/neverrun/testconfig +++ /dev/null @@ -1,4 +0,0 @@ -[setup] -runscript idontexist - -