Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -30,15 +30,15 @@ (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) (append newalist (list (list key val))))) ;; read a config file, returns two level hierarchial hash-table, ;; adds to ht if given (must be #f otherwise) -(define (read-config path . ht) +(define (read-config path ht allow-system) (if (not (file-exists? path)) - (if (null? ht)(make-hash-table) (car ht)) + (if (not ht)(make-hash-table) ht) (let ((inp (open-input-file path)) - (res (if (null? ht)(make-hash-table)(car ht))) + (res (if (not ht)(make-hash-table) ht)) (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) (section-rx (regexp "^\\[(.*)\\]\\s*$")) (blank-l-rx (regexp "^\\s*$")) (key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) (key-val-pr (regexp "^(\\S+)\\s+(.*)$")) @@ -55,28 +55,29 @@ (regex-case inl (comment-rx _ (loop (read-line inp) curr-section-name #f #f)) (blank-l-rx _ (loop (read-line inp) curr-section-name #f #f)) (include-rx ( x include-file ) (begin - (read-config include-file res) + (read-config include-file res allow-system) (loop (read-line inp) curr-section-name #f #f))) (section-rx ( x section-name ) (loop (read-line inp) section-name #f #f)) - (key-sys-pr ( x key cmd ) (let ((alist (hash-table-ref/default res curr-section-name '())) - (val (let* ((cmdres (cmd-run->list cmd)) - (status (cadr cmdres)) - (res (car cmdres))) - (if (not (eq? status 0)) - (begin - (debug:print 0 "ERROR: problem with " inl ", return code " status) - (exit 1))) - (if (null? res) - "" - (string-intersperse res " "))))) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key val)) - ;; (append alist (list (list key val)))) - (loop (read-line inp) curr-section-name #f #f))) + (key-sys-pr ( x key cmd ) (if allow-system + (let ((alist (hash-table-ref/default res curr-section-name '())) + (val (let* ((cmdres (cmd-run->list cmd)) + (status (cadr cmdres)) + (res (car cmdres))) + (if (not (eq? status 0)) + (begin + (debug:print 0 "ERROR: problem with " inl ", return code " status) + (exit 1))) + (if (null? res) + "" + (string-intersperse res " "))))) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key val)) + (loop (read-line inp) curr-section-name #f #f)) + (loop (read-line inp) curr-section-name #f #f))) (key-val-pr ( x key val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key val)) (loop (read-line inp) curr-section-name key #f))) ;; if a continued line @@ -102,11 +103,11 @@ (let* ((curr-dir (current-directory)) (configinfo (find-config fname)) (toppath (car configinfo)) (configfile (cadr configinfo))) (if toppath (change-directory toppath)) - (let ((configdat (if configfile (read-config configfile) #f))) ;; (make-hash-table)))) + (let ((configdat (if configfile (read-config configfile #f #t) #f))) ;; (make-hash-table)))) (if toppath (change-directory curr-dir)) (list configdat toppath configfile fname)))) (define (config-lookup cfgdat section var) (let ((sectdat (hash-table-ref/default cfgdat section '()))) @@ -118,10 +119,10 @@ #f)) ))) (define (setup) (let* ((configf (find-config)) - (config (if configf (read-config configf) #f))) + (config (if configf (read-config configf #f #t) #f))) (if config (setenv "RUN_AREA_HOME" (pathname-directory configf))) config)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -109,21 +109,33 @@ ;; (if (< mver 1.18) ;; (begin ;; (print "Adding tags column to tests table") ;; (sqlite3:execute db "ALTER TABLE tests ADD COLUMN tags TEXT DEFAULT '';"))) (if (< mver 1.20) - (sqlite3:execute db "CREATE TABLE test_meta (id INTEGER PRIMARY KEY, + (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));")) + CONSTRAINT test_meta_contstraint UNIQUE (id,testname));") + (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 + "ALTER TABLE tests ADD COLUMN value REAL;" + "ALTER TABLE tests ADD COLUMN tol REAL;" + "ALTER TABLE tests ADD COLUMN tol_perc REAL;" + "ALTER TABLE tests ADD COLUMN first_err TEXT;" + "ALTER TABLE tests ADD COLUMN first_warn TEXT;" + )))) (if (< mver megatest-version) (db:set-var db "MEGATEST_VERSION" megatest-version))))) ;;====================================================================== ;; meta get and set vars @@ -199,10 +211,31 @@ (number? (cadr count))) (conc " OFFSET " (cadr count)) "")) runpatt) (vector header res))) + +;; replace header and keystr with a call to runs:get-std-run-fields +;; keypatt: '(("key1" "patt1")("key2" "patt2")...) +(define (db:get-runs db keys keypatts runpatt) + (let* ((res '()) + (remfields (list "id" "runname" "state" "status" "owner" "event_time")) + (header (append (map key:get-fieldname keys) + remfields)) + (keystr (conc (keys->keystr keys) "," + (string-intersperse remfields ",")))) + (sqlite3:for-each-row + (lambda (a . x) ;; turn all the fields returned into a vector and add to the list + (set! res (cons (apply vector a x) res))) + db + (conc "SELECT " keystr " FROM runs WHERE runname LIKE ? " + (map (lambda (keypatt) + (conc "AND " (car keypatt) " LIKE " (cadr keypatt) " ")) + keypatts) + "ORDER BY event_time DESC;") + runpatt) + (vector header res))) ;; use this one for db-get-run-info (define-inline (db:get-row vec)(vector-ref vec 1)) ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) @@ -467,25 +500,6 @@ (set! result (cons waitontest-name result)))))) tests) (if (not ever-seen)(set! result (cons waitontest-name result))))) waiton) (delete-duplicates result)))) -;; -;; ;; subtract from the waiton list the "COMPLETED" tests -;; ;;(completed-tests (filter (lambda (x) -;; ;; (equal? (db:test-get-state x) "COMPLETED")) -;; ;; tests)) -;; (completed-tests (let ((non-completed (make-hash-table))) -;; (for-each (lambda (x) -;; ;; could add check for PASS here -;; (if (not (and (equal? (db:test-get-state x) "COMPLETED") -;; (equal? (db:test-get-status x) "PASS"))) -;; (hash-table-set! non-completed (db:test-get-testname x) x))) -;; ;; (debug:print 0 "Completed: " (db:test-get-testname x)))) -;; tests) -;; (filter (lambda (x) -;; (not (hash-table-ref/default non-completed (db:test-get-testname x) #f))) -;; tests))) -;; (pre-dep-names (map db:test-get-testname completed-tests)) -;; (result (lset-difference string=? waiton pre-dep-names))) -;; (print "pre-dep-names: " pre-dep-names " waiton: " waiton " result: " result) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -57,10 +57,11 @@ if -keepgoing is also specified) -rebuild-db : bring the database schema up to date -rollup N : fill run (set by :runname) with latest test(s) from past N days, requires keys -rename-run : rename run (set by :runname) to , requires keys + -update-meta : update the tests metadata for all tests Helpers -runstep stepname ... : take remaining params as comand and execute as stepname log will be in stepname.log. Best to put command in quotes -logpro file : with -exec apply logpro file to stepname.log, creates @@ -109,10 +110,11 @@ "-remove-runs" "-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)) @@ -665,10 +667,26 @@ ;; now can find our db (set! db (open-db)) (patch-db db) (sqlite3:finalize! db) (set! *didsomething* #t))) + +;;====================================================================== +;; Update the tests meta data from the testconfig files +;; + +(if (args:get-arg "-update-meta") + (begin + (if (not (setup-for-run)) + (begin + (debug:print 0 "Failed to setup, exiting") + (exit 1))) + ;; now can find our db + (set! db (open-db)) + (runs:update-all-test_meta db) + (sqlite3:finalize! db) + (set! *didsomething* #t))) (if (not *didsomething*) (debug:print 0 help)) (if (not (eq? *globalexitstatus* 0)) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -4,11 +4,11 @@ ;;====================================================================== (define (setup-env-defaults db fname run-id . already-seen) (let* ((keys (get-keys db)) (keyvals (get-key-vals db run-id)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")) - (confdat (read-config fname)) + (confdat (read-config fname #f #f)) (whatfound (make-hash-table)) (sections (list "default" thekey))) (debug:print 4 "Using key=\"" thekey "\"") (for-each (lambda (section) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -400,11 +400,11 @@ (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory *toppath*) (let* ((test-path (conc *toppath* "/tests/" test-name)) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) - (test-conf (if testexists (read-config test-configf) (make-hash-table))) + (test-conf (if testexists (read-config test-configf #f #t) (make-hash-table))) (waiton (let ((w (config-lookup test-conf "requirements" "waiton"))) (if (string? w)(string-split w)'()))) (tags (let ((t (config-lookup test-conf "setup" "tags"))) (if (string? t)(string-split t ",") '())))) (if (not testexists) @@ -428,25 +428,11 @@ (print "itestable: ")(pp (item-table->item-list itemstable)))) (if (args:get-arg "-m") (db:set-comment-for-run db run-id (args:get-arg "-m"))) ;; Here is where the test_meta table is best updated - (let ((currrecord (db:testmeta-get-record db test-name))) - (if (not currrecord) - (begin - (set! currrecord (make-vector 10 #f)) - (db:testmeta-add-record db test-name))) - (for-each - (lambda (key) - (let* ((idx (cadr key)) - (fld (car key)) - (val (config-lookup test-conf "test_meta" fld))) - (if (and val (not (equal? (vector-ref currrecord idx) val))) - (begin - (print "Updating " test-name " " fld " to " val) - (db:testmeta-update-field db test-name fld val))))) - '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)))) + (runs:update-test_meta db test-name test-conf) ;; braindead work-around for poorly specified allitems list BUG!!! FIXME (if (null? allitems)(set! allitems '(()))) (let loop ((itemdat (car allitems)) (tal (cdr allitems))) @@ -682,13 +668,48 @@ (keyvallst (keys->vallist keys #t))) (proc db keys keynames keyvallst))) (sqlite3:finalize! db) (set! *didsomething* #t)))) +;;====================================================================== +;; Rollup runs +;;====================================================================== + +;; Update the test_meta table for this test +(define (runs:update-test_meta db test-name test-conf) + (let ((currrecord (db:testmeta-get-record db test-name))) + (if (not currrecord) + (begin + (set! currrecord (make-vector 10 #f)) + (db:testmeta-add-record db test-name))) + (for-each + (lambda (key) + (let* ((idx (cadr key)) + (fld (car key)) + (val (config-lookup test-conf "test_meta" fld))) + (if (and val (not (equal? (vector-ref currrecord idx) val))) + (begin + (print "Updating " test-name " " fld " to " val) + (db:testmeta-update-field db test-name fld val))))) + '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) + +;; Update test_meta for all tests +(define (runs:update-all-test_meta db) + (let ((test-names (get-all-legal-tests))) + (for-each + (lambda (test-name) + (let* ((test-path (conc *toppath* "/tests/" test-name)) + (test-configf (conc test-path "/testconfig")) + (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) + ;; read configs with tricks turned off (i.e. no system) + (test-conf (if testexists (read-config test-configf #f #f)(make-hash-table)))) + (runs:update-test_meta db test-name test-conf))) + test-names))) + (define (runs:rollup-run db keys keynames keyvallst n) (let* ((new-run-id (register-run db keys)) - (similar-runs (db:get-similar-runs db keys)) + (similar-runs (db:get-runs db keys)) (tests-n-days (db:get-tests-n-days db similar-runs))) (for-each (lambda (test-id) (db:rollup-test db run-id test-id)) tests-n-days))) Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -10,14 +10,14 @@ (include "../items.scm") (include "../runs.scm") (include "../megatest-version.scm") (define conffile #f) -(test "Read a config" #t (hash-table? (read-config "test.config"))) -(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config"))) +(test "Read a config" #t (hash-table? (read-config "test.config" #f #f))) +(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f))) -(set! conffile (read-config "test.config")) +(set! conffile (read-config "test.config" #f #f)) (test "Get available diskspace" #t (number? (get-df "./"))) (test "Get best dir" #t (let ((bestdir (get-best-disk conffile))) (or (equal? "./" bestdir) (equal? "/tmp" bestdir)))) (test "Multiline variable" 4 (length (string-split (config-lookup conffile "metadata" "description") "\n")))