Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -241,24 +241,24 @@ ;;====================================================================== ;; T E S T S P E C I F I C D B ;;====================================================================== ;; Create the sqlite db for the individual test(s) -(define (open-test-db testpath) - (debug:print-info 11 "open-test-db " testpath) - (if (and testpath - (directory? testpath) - (file-read-access? testpath)) - (let* ((dbpath (conc testpath "/testdat.db")) +(define (open-test-db work-area) + (debug:print-info 11 "open-test-db " work-area) + (if (and work-area + (directory? work-area) + (file-read-access? work-area)) + (let* ((dbpath (conc work-area "/testdat.db")) (dbexists (file-exists? dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) (handle-exceptions exn (begin - (debug:print 0 "ERROR: problem accessing test db " testpath ", you probably should clean and re-run this test" + (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) #f) (set! db (sqlite3:open-database dbpath))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) @@ -265,30 +265,30 @@ (begin (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print-info 11 "Initialized test database " dbpath) (db:testdb-initialize db))) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - (debug:print-info 11 "open-test-db END (sucessful)" testpath) + (debug:print-info 11 "open-test-db END (sucessful)" work-area) ;; now let's test that everything is correct (handle-exceptions exn (begin - (debug:print 0 "ERROR: problem accessing test db " testpath ", you probably should clean and re-run this test" + (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) #f) ;; Is there a cheaper single line operation that will check for existance of a table ;; and raise an exception ? (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) db) (begin - (debug:print-info 11 "open-test-db END (unsucessful)" testpath) + (debug:print-info 11 "open-test-db END (unsucessful)" work-area) #f))) ;; find and open the testdat.db file for an existing test -(define (db:open-test-db-by-test-id db test-id #!key (testpath #f)) - (let* ((test-path (if testpath - testpath +(define (db:open-test-db-by-test-id db test-id #!key (work-area #f)) + (let* ((test-path (if work-area + work-area (cdb:remote-run db:test-get-rundir-from-test-id db test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) (define (db:testdb-initialize db) @@ -844,13 +844,13 @@ ) (debug:print-info 11 "db:get-tests-for-run START run-ids=" run-ids ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) res)) ;; this one is a bit broken BUG FIXME -(define (db:delete-test-step-records db test-id #!key (testpath #f)) +(define (db:delete-test-step-records db test-id #!key (work-area #f)) ;; Breaking it into two queries for better file access interleaving - (let* ((tdb (db:open-test-db-by-test-id db test-id testpath: testpath))) + (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) ;; test db's can go away - must check every time (if tdb (begin (sqlite3:execute tdb "DELETE FROM test_steps;") (sqlite3:execute tdb "DELETE FROM test_data;") @@ -986,12 +986,12 @@ ;; given a test-info record, patch in the latest data from the testdat.db file ;; found in the test run directory ;; ;; NOT USED ;; -(define (db:patch-tdb-data-into-test-info db test-id res #!key (testpath #f)) - (let ((tdb (db:open-test-db-by-test-id db test-id testpath: testpath))) +(define (db:patch-tdb-data-into-test-info db test-id res #!key (work-area #f)) + (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) ;; get state and status from megatest.db in real time ;; other fields that perhaps should be updated: ;; fail_count ;; pass_count ;; final_logf @@ -1631,13 +1631,13 @@ ;;====================================================================== ;; T E S T D A T A ;;====================================================================== -(define (db:csv->test-data db test-id csvdata #!key (testpath #f)) +(define (db:csv->test-data db test-id csvdata #!key (work-area #f)) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) - (let ((tdb (db:open-test-db-by-test-id db test-id testpath: testpath))) + (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) (if tdb (let ((csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) @@ -1692,12 +1692,12 @@ test-id category variable value expected tol units (if comment comment "") status type))) csvlist) (sqlite3:finalize! tdb))))) ;; get a list of test_data records matching categorypatt -(define (db:read-test-data db test-id categorypatt #!key (testpath #f)) - (let ((tdb (db:open-test-db-by-test-id db test-id testpath: testpath))) +(define (db:read-test-data db test-id categorypatt #!key (work-area #f)) + (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) (if tdb (let ((res '())) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) @@ -1706,28 +1706,28 @@ (sqlite3:finalize! tdb) (reverse res)) '()))) ;; NOTE: Run this local with #f for db !!! -(define (db:load-test-data db test-id #!key (testpath #f)) +(define (db:load-test-data db test-id #!key (work-area #f)) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) - (db:csv->test-data db test-id lin testpath: testpath) + (db:csv->test-data db test-id lin work-area: work-area) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status to - (db:test-data-rollup db test-id #f testpath: testpath)) + (db:test-data-rollup db test-id #f work-area: work-area)) ;; 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. ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored -(define (db:test-data-rollup db test-id status #!key (testpath #f)) - (let ((tdb (db:open-test-db-by-test-id db test-id testpath: testpath)) +(define (db:test-data-rollup db test-id status #!key (work-area #f)) + (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (fail-count 0) (pass-count 0)) (if tdb (begin (sqlite3:for-each-row @@ -1776,12 +1776,12 @@ (define (db:step-get-time-as-string vec) (seconds->time-string (db:step-get-event_time vec))) ;; db-get-test-steps-for-run -(define (db:get-steps-for-test db test-id #!key (testpath #f)) - (let* ((tdb (db:open-test-db-by-test-id db test-id testpath: testpath)) +(define (db:get-steps-for-test db test-id #!key (work-area #f)) + (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (res '())) (if tdb (begin (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) @@ -1793,12 +1793,12 @@ (reverse res)) '()))) ;; get a pretty table to summarize steps ;; -(define (db:get-steps-table db test-id #!key (testpath #f)) - (let ((steps (db:get-steps-for-test db test-id testpath: testpath))) +(define (db:get-steps-table db test-id #!key (work-area #f)) + (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 "step=" step) @@ -1853,12 +1853,12 @@ (else #f))))) res))) ;; get a pretty table to summarize steps ;; -(define (db:get-steps-table-list db test-id #!key (testpath #f)) - (let ((steps (db:get-steps-for-test db test-id testpath: testpath))) +(define (db:get-steps-table-list db test-id #!key (work-area #f)) + (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 "step=" step) @@ -1995,14 +1995,14 @@ (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) -(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile #!key (testpath #f)) +(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile #!key (work-area #f)) (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name) ;; db:open-test-db-by-test-id does cdb:remote-run - (let* ((tdb (db:open-test-db-by-test-id db test-id testpath: testpath)) + (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -53,13 +53,13 @@ (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)) - (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; How is testpath different from work-area ?? + (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) - (work-area (assoc/default 'work-area cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) ;; (runremote (assoc/default 'runremote cmdinfo)) (transport (assoc/default 'transport cmdinfo)) @@ -133,11 +133,11 @@ (alist->env-vars env-ovrd) (set-megatest-env-vars run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info - (tests:set-meta-info #f test-id run-id test-name itemdat 0 testpath) + (tests:set-meta-info #f test-id run-id test-name itemdat 0 work-area) (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) @@ -208,11 +208,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) ;; DO NOT remote - (db:teststep-set-status! #f test-id stepname "start" "-" #f #f testpath: testpath) + (db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: work-area) ;; 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) @@ -226,11 +226,11 @@ (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) - (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna testpath: testpath)) + (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: work-area)) (if logpro-used (cdb:test-set-log! *runremote* test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) @@ -276,11 +276,11 @@ (kill-tries 0)) (let loop ((minutes (calc-minutes))) (begin (set! kill-job? (test-get-kill-request test-id)) ;; run-id test-name itemdat)) ;; open-run-close not needed for test-set-meta-info - (tests:set-meta-info #f test-id run-id test-name itemdat minutes testpath) + (tests:set-meta-info #f test-id run-id test-name itemdat minutes work-area) (if kill-job? (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -126,10 +126,11 @@ -list-targets : list the targets in runconfigs.config -list-db-targets : list the target combinations used in the db -show-config : dump the internal representation of the megatest.config file -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 -rebuild-db : bring the database schema up to date -update-meta : update the tests metadata for all tests -env2file fname : write the environment to fname.csh and fname.sh @@ -238,10 +239,11 @@ "-list-disks" "-list-targets" "-list-db-targets" "-show-runconfig" "-show-config" + "-show-cmdinfo" ;; queries "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests "-remove-runs" @@ -438,10 +440,17 @@ ((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))) + +(if (args:get-arg "-show-cmdinfo") + (let ((data (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))) + (if (equal? (args:get-arg "-dumpmode") "json") + (json-write data) + (pp data)) + (set! *didsomething* #t))) ;;====================================================================== ;; Remove old run(s) ;;====================================================================== @@ -804,10 +813,11 @@ (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) ;; (set! *runremote* runremote) (set! *transport-type* (string->symbol transport)) (if (not (setup-for-run)) @@ -814,11 +824,11 @@ (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) ;; DO NOT remote run, makes calls to the testdat.db test db. - (db:teststep-set-status! db test-id step state status msg logfile testpath: testpath) + (db:teststep-set-status! db test-id step state status msg logfile work-area: work-area) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") @@ -853,10 +863,11 @@ (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) (change-directory testpath) ;; (set! *runremote* runremote) @@ -870,11 +881,11 @@ ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close - (db:load-test-data db test-id testpath: testpath)) + (db:load-test-data db test-id work-area: work-area)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) (cdb:test-set-log! *runremote* test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote @@ -902,11 +913,11 @@ (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test ;; DO NOT run remote - (db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile testpath: testpath) + (db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile work-area: work-area) ;; run the test step (debug:print-info 2 "Running \"" fullcmd "\"") (change-directory startingdir) (set! exitstat (system fullcmd)) ;; cmd params)) (set! *globalexitstatus* exitstat) @@ -922,11 +933,11 @@ (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) (cdb:test-set-log! *runremote* test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) ;; DO NOT run remote - (db:teststep-set-status! db test-id stepname "end" exitstat msg logfile testpath: testpath)) + (db:teststep-set-status! db test-id stepname "end" exitstat msg logfile work-area: work-area)) ))) (if (or (args:get-arg "-test-status") (args:get-arg "-set-values")) (let ((newstatus (cond ((number? status) (if (equal? status 0) "PASS" "FAIL")) @@ -949,11 +960,11 @@ ;; (sqlite3:finalize! db) (exit 6))) (let* ((msg (args:get-arg "-m")) (numoth (length (hash-table-keys otherdata)))) ;; Convert to rpc inside the tests:test-set-status! call, not here - (tests:test-set-status! test-id state newstatus msg otherdata testpath: testpath)))) + (tests:test-set-status! test-id state newstatus msg otherdata work-area: work-area)))) (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -244,11 +244,11 @@ (pop-directory) result))) ;; Do not rpc this one, do the underlying calls!!! -(define (tests:test-set-status! test-id state status comment dat #!key (testpath #f)) +(define (tests:test-set-status! test-id state status comment dat #!key (work-area #f)) (debug:print-info 4 "tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat) (let* ((db #f) (real-status status) (otherdat (if dat dat (make-hash-table))) (testdat (cdb:get-test-info-by-id *runremote* test-id)) @@ -290,11 +290,11 @@ (cdb:test-set-status-state *runremote* test-id real-status state (if waived waived comment))) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) - (db:test-data-rollup #f test-id status testpath: testpath)) + (db:test-data-rollup #f test-id status work-area: work-area)) ;; add metadata (need to do this way to avoid SQL injection issues) ;; :first_err ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) @@ -572,13 +572,13 @@ (cdb:tests-update-uname-host *runremote* test-id uname hostname)) ;;(sqlite3:execute db "UPDATE tests SET uname=?,host=? WHERE id=?;" uname hostname test-id)) ;;(sqlite3:finalize! db)) ) -(define (tests:set-meta-info db test-id run-id testname itemdat minutes testpath) +(define (tests:set-meta-info db test-id run-id testname itemdat minutes work-area) ;; DOES cdb:remote-run under the hood! - (let* ((tdb (db:open-test-db-by-test-id db test-id testpath: testpath)) + (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (num-records (test:tdb-get-rundat-count tdb)) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) (if (eq? (modulo num-records 10) 0) ;; every ten records update central (let ((uname (get-uname "-srvpio")) Index: tests/fullrun/config/mt_include_1.config ================================================================== --- tests/fullrun/config/mt_include_1.config +++ tests/fullrun/config/mt_include_1.config @@ -1,8 +1,8 @@ [setup] # exectutable /path/to/megatest -max_concurrent_jobs 100 +max_concurrent_jobs 150 linktree #{getenv MT_RUN_AREA_HOME}/tmp/mt_links [jobtools] useshell yes