Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -1,11 +1,11 @@ FILES=$(glob *.scm) megatest: common.scm configf.scm db.scm keys.scm launch.scm megatest.scm process.scm runs.scm gui.scm csc megatest.scm -dashboard: dashboard.scm dashboard-tests.scm +dashboard: megatest dashboard.scm dashboard-tests.scm csc dashboard.scm $(PREFIX)/bin/megatest : megatest @echo Installing to PREFIX=$(PREFIX), use ^C to cancel and change sleep 5 @@ -14,8 +14,8 @@ $(PREFIX)/bin/dashboard : dashboard cp dashboard $(PREFIX)/bin/dashboard install : $(PREFIX)/bin/megatest $(PREFIX)/bin/dashboard -test: tests/tests.scm +test: megatest tests/tests.scm cd tests;csi -I .. -b -n tests.scm Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -25,12 +25,12 @@ (if (null? remcwd) (list #f #f #f) ;; #f #f) (loop remcwd)))))))) (define (config:assoc-safe-add alist key val) - (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) - (append newalist (list (list key val))))) + (let ((newalist (filter (lambda (x)(not (equal? key x))) alist))) + (append alist (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) (if (not (file-exists? path)) @@ -40,28 +40,25 @@ (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+(.*)$")) - (comment-rx (regexp "^\\s*#.*")) - (cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))) + (comment-rx (regexp "^\\s*#.*"))) (let loop ((inl (read-line inp)) - (curr-section-name "default") - (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere - (lead #f)) + (curr-section-name "default")) (if (eof-object? inl) (begin (close-input-port inp) res) (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)) + (comment-rx _ (loop (read-line inp) curr-section-name)) + (blank-l-rx _ (loop (read-line inp) curr-section-name)) (include-rx ( x include-file ) (begin (read-config include-file res) - (loop (read-line inp) curr-section-name #f #f))) - (section-rx ( x section-name ) (loop (read-line inp) section-name #f #f)) + (loop (read-line inp) curr-section-name))) + (section-rx ( x section-name ) (loop (read-line inp) section-name)) (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)) @@ -72,33 +69,18 @@ "" (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))) + (loop (read-line inp) curr-section-name))) (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 - (cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) - (if var-flag ;; if set to a string then we have a continued var - (let ((newval (conc - (config-lookup res curr-section-name var-flag) "\n" - ;; trim lead from the incoming whsp to support some indenting. - (if lead - (string-substitute (regexp lead) "" whsp) - "") - val))) - ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist var-flag newval)) - (loop (read-line inp) curr-section-name var-flag (if lead lead whsp))) - (loop (read-line inp) curr-section-name #f #f)))) + ;; (append alist (list (list key val)))) + (loop (read-line inp) curr-section-name))) (else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"") - (set! var-flag #f) - (loop (read-line inp) curr-section-name #f #f)))))))) + (loop (read-line inp) curr-section-name)))))))) (define (find-and-read-config fname) (let* ((curr-dir (current-directory)) (configinfo (find-config fname)) (toppath (car configinfo)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -79,12 +79,11 @@ 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));") (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);") - (patch-db db))) + (sqlite3:execute db "CREATE TABLE access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);"))) db)) ;;====================================================================== ;; TODO: ;; put deltas into an assoc list with version numbers @@ -96,36 +95,24 @@ (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 "ALTER TABLE tests ADD COLUMN tags TEXT DEFAULT '';") (db:set-var db "MEGATEST_VERSION" 1.17) ) (let ((mver (db:get-var db "MEGATEST_VERSION"))) - (print "Current schema version: " mver " current megatest version: " megatest-version) - (if (not mver) + (if(not mver) (begin (print "Adding megatest-version to metadata") (sqlite3:execute db (db:set-var db "MEGATEST_VERSION" megatest-version)))) - ;; (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, - 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));")) - (if (< mver megatest-version) - (db:set-var db "MEGATEST_VERSION" megatest-version))))) + (if (< mver 1.18) + (begin + (print "Adding tags column to tests table") + (sqlite3:execute db "ALTER TABLE tests ADD COLUMN tags TEXT DEFAULT '';"))) + (db:set-var db "MEGATEST_VERSION" megatest-version) + ))) ;;====================================================================== ;; meta get and set vars ;;====================================================================== @@ -351,54 +338,10 @@ (sqlite3:execute db "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" rundir run-id testname item-path)) -;;====================================================================== -;; Tests meta data -;;====================================================================== - -;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk -(define (make-db:testmeta)(make-vector 10)) -(define-inline (db:testmeta-get-id vec) (vector-ref vec 0)) -(define-inline (db:testmeta-get-testname vec) (vector-ref vec 1)) -(define-inline (db:testmeta-get-author vec) (vector-ref vec 2)) -(define-inline (db:testmeta-get-owner vec) (vector-ref vec 3)) -(define-inline (db:testmeta-get-description vec) (vector-ref vec 4)) -(define-inline (db:testmeta-get-reviewed vec) (vector-ref vec 5)) -(define-inline (db:testmeta-get-iterated vec) (vector-ref vec 6)) -(define-inline (db:testmeta-get-avg_runtime vec) (vector-ref vec 7)) -(define-inline (db:testmeta-get-avg_disk vec) (vector-ref vec 8)) -(define-inline (db:testmeta-get-tags vec) (vector-ref vec 9)) -(define-inline (db:testmeta-set-id! vec val)(vector-set! vec 0 val)) -(define-inline (db:testmeta-set-testname! vec val)(vector-set! vec 1 val)) -(define-inline (db:testmeta-set-author! vec val)(vector-set! vec 2 val)) -(define-inline (db:testmeta-set-owner! vec val)(vector-set! vec 3 val)) -(define-inline (db:testmeta-set-description! vec val)(vector-set! vec 4 val)) -(define-inline (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val)) -(define-inline (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val)) -(define-inline (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val)) -(define-inline (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val)) - -;; read the record given a testname -(define (db:testmeta-get-record db testname) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags) - (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags))) - db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;" - testname) - res)) - -;; create a new record for a given testname -(define (db:testmeta-add-record db testname) - (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname) VALUES (?);" testname)) - -;; 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 ;;====================================================================== ;; Run steps ;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time @@ -486,6 +429,5 @@ ;; (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-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,3 +1,1 @@ -;; Always use two digit decimal -;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. -(define megatest-version 1.20) +(define megatest-version 1.19) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -54,13 +54,10 @@ -keepgoing : continue running until no jobs are \"LAUNCHED\" or \"NOT_STARTED\" -rerun FAIL,WARN... : re-run if called on a test that previously ran (nullified 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 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 @@ -91,13 +88,10 @@ "-set-toplog" "-runstep" "-logpro" "-m" "-rerun" - "-days" - "-rename-run" - "-to" "-debug" ;; for *verbosity* > 2 ) (list "-h" "-force" "-xterm" @@ -108,11 +102,10 @@ "-runall" ;; run all tests "-remove-runs" "-keepgoing" "-usequeue" "-rebuild-db" - "-rollup" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) args:arg-hash 0)) @@ -265,29 +258,31 @@ ;; if still ok to run tasks ;; process deferred tasks per above steps ;; run all tests are are Not COMPLETED and PASS or CHECK (if (args:get-arg "-runall") - (general-run-call - "-runall" - "run all tests" - (lambda (db keys keynames keyvallst) - (let* ((test-names (get-all-legal-tests))) ;; "PROD" is ignored for now - (debug:print 1 "INFO: Attempting to start the following tests...") - (debug:print 1 " " (string-intersperse test-names ",")) - (run-tests db test-names))))) - -;;====================================================================== -;; Rollup into a run -;;====================================================================== -(if (args:get-arg "-rollup") - (general-run-call - "-rollup" - "rollup tests" - (lambda (db keys keynames keyvallst) - (let ((n (args:get-arg "-rollup"))) - (runs:rollup db keys keynames keyvallst n))))) + (if (not (args:get-arg ":runname")) + (begin + (debug:print 0 "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname") + (exit 2)) + (let* ((db (if (setup-for-run) + (open-db) + (begin + (debug:print 0 "Failed to setup, exiting") + (exit 1))))) + (if (not (car *configinfo*)) + (begin + (debug:print 0 "ERROR: Attempted to run a test but run area config file not found") + (exit 1)) + ;; put test parameters into convenient variables + (let* ((test-names (get-all-legal-tests))) ;; "PROD" is ignored for now + (debug:print 1 "INFO: Attempting to start the following tests...") + (debug:print 1 " " (string-intersperse test-names ",")) + (run-tests db test-names))) + ;; (run-waiting-tests db) + (sqlite3:finalize! db) + (set! *didsomething* #t)))) ;;====================================================================== ;; run one test ;;====================================================================== @@ -302,17 +297,35 @@ ;; - step completed, exit status, timestamp ;; 6. test phone home ;; - if test run time > allowed run time then kill job ;; - if cannot access db > allowed disconnect time then kill job +(define (runtests) + (if (not (args:get-arg ":runname")) + (begin + (debug:print 0 "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname") + (exit 2)) + (let ((db #f)) + (if (not (setup-for-run)) + (begin + (debug:print 0 "Failed to setup, exiting") + (exit 1))) + (set! db (open-db)) + (if (not (car *configinfo*)) + (begin + (debug:print 0 "ERROR: Attempted to run a test but run area config file not found") + (exit 1)) + ;; put test parameters into convenient variables + (let* ((test-names (string-split (args:get-arg "-runtests") ","))) + (run-tests db test-names))) + ;; run-waiting-tests db) + (sqlite3:finalize! db) + ;; (run-waiting-tests #f) + (set! *didsomething* #t)))) + (if (args:get-arg "-runtests") - (general-run-call - "-runtests" - "run a test" - (lambda (db keys keynames keyvallst) - (let ((test-names (string-split (args:get-arg "-runtests") ","))) - (run-tests db test-names))))) + (runtests)) ;;====================================================================== ;; execute the test ;; - gets called on remote host ;; - receives info from the -execute param @@ -492,12 +505,11 @@ (eq? (vector-ref exit-info 2) 0)) "PASS" "FAIL") "FAIL") itemdat (args:get-arg "-m")))) ;; for automated creation of the rollup html file this is a good place... - (if (not (equal? item-path "")) - (tests:summarize-items db run-id test-name #f)) ;; don't force - just update if no + (tests:summarize-items db run-id test-name #f) ;; don't force - just update if no ) (mutex-unlock! m) ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc test-name "-run.log")))) ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -426,28 +426,10 @@ (begin (print "items: ")(pp (item-assoc->item-list items)) (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)))) - ;; braindead work-around for poorly specified allitems list BUG!!! FIXME (if (null? allitems)(set! allitems '(()))) (let loop ((itemdat (car allitems)) (tal (cdr allitems))) ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) @@ -651,44 +633,5 @@ ;; (debug:print 1 "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) )))) )) runs))) - -;;====================================================================== -;; Routines for manipulating runs -;;====================================================================== - -;; Since many calls to a run require pretty much the same setup -;; this wrapper is used to reduce the replication of code -(define (general-run-call switchname action-desc proc) - (if (not (args:get-arg ":runname")) - (begin - (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname") - (exit 2)) - (let ((db #f)) - (if (not (setup-for-run)) - (begin - (debug:print 0 "Failed to setup, exiting") - (exit 1))) - (set! db (open-db)) - (if (not (car *configinfo*)) - (begin - (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found") - (exit 1)) - ;; Extract out stuff needed in most or many calls - ;; here then call proc - (let* ((keys (db-get-keys db)) - (keynames (map key:get-fieldname keys)) - (keyvallst (keys->vallist keys #t))) - (proc db keys keynames keyvallst))) - (sqlite3:finalize! db) - (set! *didsomething* #t)))) - -(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)) - (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/test.config ================================================================== --- tests/test.config +++ tests/test.config @@ -17,15 +17,5 @@ blah nada # now inlcude a file tha tdoes exist [include megatest.config] - -[metadata] -description This is a multiline - description. The leading whitespace is discarded - irrespective of amount of indenting. - This line is indented more. - - -author matt -lastreview never Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -18,11 +18,10 @@ (set! conffile (read-config "test.config")) (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"))) ;; db (define row (vector "a" "b" "c" "blah")) (define header (list "col1" "col2" "col3" "col4")) (test "Get row by header" "blah" (db:get-value-by-header row header "col4")) @@ -61,11 +60,11 @@ (test "get all legal tests" (list "runfirst" "runwithfirst" "singletest" "singletest2" "sqlitespeed") (sort (get-all-legal-tests) string<=?)) (test "register-test, test info" "NOT_STARTED" (begin - (register-test *db* 1 "nada" "" '("tag1" "tag2" "tag3")) + (register-test *db* 1 "nada" "") (test:get-state (db:get-test-info *db* 1 "nada" "")))) (test "get-keys" "sysname" (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0))))))) (define remargs (args:get-args Index: tests/tests/runfirst/testconfig ================================================================== --- tests/tests/runfirst/testconfig +++ tests/tests/runfirst/testconfig @@ -12,13 +12,5 @@ [itemstable] BLOCK a b TOCK 1 2 -[test_meta] -author matt -owner bob -description This test must - be run before the other tests - -tags first,single -reviewed 1/1/1965