Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use sqlite3 srfi-1 posix regex-case base64 format dot-locking) +(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml) (require-extension sqlite3 regex posix) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -24,16 +24,16 @@ (let* ((keys (config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys))) ;; (sqlite3:execute db "PRAGMA synchronous = OFF;") - (sqlite3:execute db "CREATE TABLE keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") (for-each (lambda (key) (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" (key:get-fieldname key)(key:get-fieldtype key))) keys) (sqlite3:execute db (conc - "CREATE TABLE runs (id INTEGER PRIMARY KEY, " + "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " fieldstr (if havekeys "," "") "runname TEXT," "state TEXT DEFAULT ''," "status TEXT DEFAULT ''," "owner TEXT DEFAULT ''," @@ -42,11 +42,11 @@ "fail_count INTEGER DEFAULT 0," "pass_count INTEGER DEFAULT 0," "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) (sqlite3:execute db - "CREATE TABLE tests + "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER, testname TEXT, host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, @@ -66,23 +66,23 @@ pass_count INTEGER DEFAULT 0, 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 test_steps + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a',event_time TIMESTAMP, comment TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (sqlite3:execute db "CREATE TABLE extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") - (sqlite3:execute db "CREATE TABLE metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (id,var));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + CONSTRAINT metadat_constraint UNIQUE (var));") (db:set-var db "MEGATEST_VERSION" megatest-version) - (sqlite3:execute db "CREATE TABLE access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") (patch-db db))) db)) ;;====================================================================== ;; TODO: @@ -93,15 +93,26 @@ (handle-exceptions exn (begin (print "Exception: " exn) (print "ERROR: Possible out of date schema, attempting to add table metadata...") - (sqlite3:execute db "CREATE TABLE metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (id,var));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, + CONSTRAINT metadat_constraint UNIQUE (var));") (db:set-var db "MEGATEST_VERSION" 1.17) ) - (let ((mver (db:get-var db "MEGATEST_VERSION"))) + (let ((mver (db:get-var db "MEGATEST_VERSION")) + (test-meta-def "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY, + testname TEXT DEFAULT '', + author TEXT DEFAULT '', + owner TEXT DEFAULT '', + description TEXT DEFAULT '', + reviewed TIMESTAMP, + iterated TEXT DEFAULT '', + avg_runtime REAL, + avg_disk REAL, + tags TEXT DEFAULT '', + CONSTRAINT test_meta_constraint UNIQUE (testname));")) (print "Current schema version: " mver " current megatest version: " megatest-version) (if (not mver) (begin (print "Adding megatest-version to metadata") (sqlite3:execute db (db:set-var db "MEGATEST_VERSION" megatest-version)))) @@ -109,21 +120,11 @@ ;; (begin ;; (print "Adding tags column to tests table") ;; (sqlite3:execute db "ALTER TABLE tests ADD COLUMN tags TEXT DEFAULT '';"))) (if (< mver 1.21) (begin - (sqlite3:execute db "CREATE TABLE test_meta (id INTEGER PRIMARY KEY, - testname TEXT DEFAULT '', - author TEXT DEFAULT '', - owner TEXT DEFAULT '', - description TEXT DEFAULT '', - reviewed TIMESTAMP, - iterated TEXT DEFAULT '', - avg_runtime REAL, - avg_disk REAL, - tags TEXT DEFAULT '', - CONSTRAINT test_meta_contstraint UNIQUE (id,testname));") + (sqlite3:execute db test-meta-def) (for-each (lambda (stmt) (sqlite3:execute db stmt)) (list "ALTER TABLE tests ADD COLUMN expected_value REAL;" ;; DO NOT Add a default, we want it to be NULL @@ -132,10 +133,21 @@ "ALTER TABLE tests ADD COLUMN tol_perc REAL;" "ALTER TABLE tests ADD COLUMN first_err TEXT;" "ALTER TABLE tests ADD COLUMN first_warn TEXT;" "ALTER TABLE tests ADD COLUMN units TEXT;" )))) + (if (< mver 1.22) + (begin + (sqlite3:execute db "DROP TABLE test_meta;") + (sqlite3:execute db test-meta-def) + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, + test_id INTEGER, + category TEXT DEFAULT '', + variable TEXT, + value, + comment TEXT DEFAULT '', + CONSTRAINT test_data UNIQUE (test_id,category,variable));"))) (if (< mver megatest-version) (db:set-var db "MEGATEST_VERSION" megatest-version))))) ;;====================================================================== ;; meta get and set vars @@ -152,11 +164,17 @@ (let ((valnum (string->number res))) (if valnum valnum res)) res))) (define (db:set-var db var val) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)) + ;; Odd, I thought that if a constraint was placed on column then an insert with duplicate data + ;; would fail and the insert would fall back to replace. + ;; NB// accidently included primary key in the unique constraint which does not work. + (let ((have (db:get-var db var))) + ;; (if have + ;; (sqlite3:execute db "UPDATE metadat SET val=? WHERE var=?;" val var) + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) ;; use a global for some primitive caching, it is just silly to re-read the db ;; over and over again for the keys since they never change (define *db-keys* #f) @@ -443,11 +461,35 @@ ;; update one of the testmeta fields (define (db:testmeta-update-field db testname field value) (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) ;;====================================================================== -;; Steps +;; T E S T D A T A +;;====================================================================== +(define (db:csv->testdata db test-id csvdata) + (let ((csvlist (csv->list csvdata))) + (for-each + (lambda (csvrow) + (apply sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,comment) VALUES (?,?,?,?,?);" + test-id (take (append csvrow '("" "" "" "")) 4))) + csvlist))) + +(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)) + (test-id (db:test-get-id testdat))) + (debug:print 1 "Enter records to insert in the test_data table, four fields, comma separated per line") + (debug:print 4 "itemdat: " itemdat ", test-name: " test-name ", test-id: " test-id) + (let loop ((lin (read-line))) + (if (not (eof-object? lin)) + (begin + (debug:print 4 lin) + (db:csv->testdata db test-id lin) + (loop (read-line))))))) + +;;====================================================================== +;; S T E P S ;;====================================================================== ;; Run steps ;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time (define (make-db:step)(make-vector 6)) (define-inline (db:step-get-id vec) (vector-ref vec 0)) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,3 +1,3 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. -(define megatest-version 1.22) +(define megatest-version 1.23) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -46,10 +46,15 @@ :tol : |value-expect| <= tol :units : name of the units for value, expected_value and tol :first_err : record an error message :first_warn : record a warning message +Arbitrary test data loading + -load-test-data : read test specific data for storage in the test_data table + from standard in. Each line is comma delimited with four + fields category,variable,value,comment + Queries -list-runs patt : list runs matching pattern \"patt\", % is the wildcard -testpatt patt : in list-runs show only these tests, % is the wildcard -itempatt patt : in list-runs show only tests with items that match patt -showkeys : show the keys used in this megatest setup @@ -120,10 +125,11 @@ "-force" "-xterm" "-showkeys" "-test-status" "-set-values" + "-load-test-data" "-summarize-items" "-gui" "-runall" ;; run all tests "-remove-runs" "-keepgoing" @@ -559,10 +565,11 @@ (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status (args:get-arg "-set-toplog") (args:get-arg "-test-status") (args:get-arg "-set-values") + (args:get-arg "-load-test-data") (args:get-arg "-runstep") (args:get-arg "-summarize-items")) (if (not (getenv "MT_CMDINFO")) (begin (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") @@ -582,10 +589,12 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) + (if (args:get-arg "-load-test-data") + (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"))) (if (args:get-arg "-set-toplog") (test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -64,11 +64,11 @@ make PLATFORM=linux PREFIX=$PREFIX make PLATFORM=linux PREFIX=$PREFIX install cd $BUILDHOME fi -for f in readline apropos base64 regex-literals format regex-case test coops trace; do +for f in readline apropos base64 regex-literals format regex-case test coops trace csv dot-locking; do chicken-install $PROX $f done cd $BUILDHOME