Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -1,21 +1,21 @@ 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: megatest dashboard.scm dashboard-tests.scm +dashboard: 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 cp megatest $(PREFIX)/bin/megatest -$(PREFIX)/bin/dashboard : dashboard +$(PREFIX)/bin/dashboard : dashboard $(FILES) cp dashboard $(PREFIX)/bin/dashboard install : $(PREFIX)/bin/megatest $(PREFIX)/bin/dashboard -test: megatest tests/tests.scm +test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -25,70 +25,89 @@ (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 x))) alist))) - (append alist (list (list key val))))) + (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+(.*)$")) - (comment-rx (regexp "^\\s*#.*"))) + (comment-rx (regexp "^\\s*#.*")) + (cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))) (let loop ((inl (read-line inp)) - (curr-section-name "default")) + (curr-section-name "default") + (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere + (lead #f)) (if (eof-object? inl) (begin (close-input-port inp) res) (regex-case inl - (comment-rx _ (loop (read-line inp) curr-section-name)) - (blank-l-rx _ (loop (read-line inp) curr-section-name)) + (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) - (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)) - (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))) + (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 ) (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)) - ;; (append alist (list (list key val)))) - (loop (read-line inp) curr-section-name))) + (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)))) (else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"") - (loop (read-line inp) curr-section-name)))))))) + (set! var-flag #f) + (loop (read-line inp) curr-section-name #f #f)))))))) (define (find-and-read-config fname) (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 '()))) @@ -100,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: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -58,10 +58,48 @@ (store-label "testid" (iup:label "TestId " #:expand "HORIZONTAL") (lambda (testdat) (db:test-get-id testdat)))))))) + +;;====================================================================== +;; Test meta panel +;;====================================================================== +(define (test-meta-panel testmeta store-meta) + (iup:frame + #:title "Test Meta Data" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Author: " + "Owner: " + "Reviewed: " + "Tags: " + "Description: " + )) + (list (iup:label "" #:expand "VERTICAL")))) + (apply iup:vbox ; #:expand "YES" + (list + (store-meta "author" + (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-author testmeta))) + (store-meta "owner" + (iup:label (db:testmeta-get-owner testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-owner testmeta))) + (store-meta "reviewed" + (iup:label (db:testmeta-get-reviewed testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-reviewed testmeta))) + (store-meta "tags" + (iup:label (db:testmeta-get-tags testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-tags testmeta))) + (store-meta "description" + (iup:label (db:testmeta-get-description testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-description testmeta))) + ))))) + ;;====================================================================== ;; Run info panel ;;====================================================================== (define (run-info-panel keydat testdat runname) @@ -201,10 +239,15 @@ "runname") #f)) ;(teststeps (if testdat (db:get-steps-for-test db test-id) #f)) (logfile "/this/dir/better/not/exist") (rundir logfile) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) + (testname (if testdat (db:test-get-testname testdat) "n/a")) + (testmeta (if testdat + (let ((tm (db:testmeta-get-record db testname))) + (if tm tm (make-db:testmeta))) + (make-db:testmeta))) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) (iup:send-url logfile) (message-window (conc "File " logfile " not found"))))) @@ -229,15 +272,28 @@ ;(mutex-unlock! mx1) ) (begin (db:test-set-testname! testdat "DEAD OR DELETED TEST")))))) (widgets (make-hash-table)) + (meta-widgets (make-hash-table)) (self #f) (store-label (lambda (name lbl cmd) (hash-table-set! widgets name (lambda (testdat) (let ((newval (cmd testdat)) + (oldval (iup:attribute lbl "TITLE"))) + (if (not (equal? newval oldval)) + (begin + ;(mutex-lock! mx1) + (iup:attribute-set! lbl "TITLE" newval) + ;(mutex-unlock! mx1) + ))))) + lbl)) + (store-meta (lambda (name lbl cmd) + (hash-table-set! meta-widgets name + (lambda (testmeta) + (let ((newval (cmd testmeta)) (oldval (iup:attribute lbl "TITLE"))) (if (not (equal? newval oldval)) (begin ;(mutex-lock! mx1) (iup:attribute-set! lbl "TITLE" newval) @@ -255,11 +311,12 @@ #:title testfullname (iup:vbox ; #:expand "YES" ;; The run and test info (iup:hbox ; #:expand "YES" (run-info-panel keydat testdat runname) - (test-info-panel testdat store-label widgets)) + (test-info-panel testdat store-label widgets) + (test-meta-panel testmeta store-meta)) (host-info-panel testdat store-label) ;; The controls (iup:frame #:title "Actions" (iup:hbox (iup:button "View Log" #:action viewlog #:size "120x") Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -62,11 +62,10 @@ run_duration INTEGER DEFAULT 0, comment TEXT DEFAULT '', event_time TIMESTAMP, fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, - tags TEXT DEFAULT '', 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 @@ -79,11 +78,12 @@ 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);"))) + (sqlite3:execute db "CREATE TABLE access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + (patch-db db))) db)) ;;====================================================================== ;; TODO: ;; put deltas into an assoc list with version numbers @@ -95,24 +95,48 @@ (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"))) - (if(not mver) + (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)))) - (if (< mver 1.18) + ;; (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) (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) - ))) + (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));") + (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 ;;====================================================================== @@ -186,10 +210,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)) @@ -298,12 +343,12 @@ (define (db:estimated-tests-remaining db run-id) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) - db - "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING') AND run_id=?;" run-id) + db ;; NB// KILLREQ means the jobs is still probably running + "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ') AND run_id=?;" run-id) res)) ;; NB// Sync this with runs:get-test-info (define (db:get-test-info db run-id testname item-path) (let ((res #f)) @@ -338,10 +383,54 @@ (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,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) 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 @@ -368,28 +457,28 @@ db "SELECT id,test_id,stepname,state,status,event_time FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))) -;; check that *all* the prereqs are "COMPLETED" -(define (db-get-prereqs-met db run-id waiton) - (let ((res #f) - (not-complete 0) - (tests (db-get-tests-for-run db run-id))) - (for-each - (lambda (test-name) - (for-each - (lambda (test) - (if (equal? (db:test-get-testname test) test-name) - (begin - (set! res #t) - (if (not (equal? (db:test-get-state test) "COMPLETED")) - (set! not-complete (+ 1 not-complete)))))) - tests)) - waiton) - (and (or (null? waiton) res) - (eq? not-complete 0)))) +;; ;; check that *all* the prereqs are "COMPLETED" +;; (define (db-get-prereqs-met db run-id waiton) +;; (let ((res #f) +;; (not-complete 0) +;; (tests (db-get-tests-for-run db run-id))) +;; (for-each +;; (lambda (test-name) +;; (for-each +;; (lambda (test) +;; (if (equal? (db:test-get-testname test) test-name) +;; (begin +;; (set! res #t) +;; (if (not (equal? (db:test-get-state test) "COMPLETED")) +;; (set! not-complete (+ 1 not-complete)))))) +;; tests)) +;; waiton) +;; (and (or (null? waiton) res) +;; (eq? not-complete 0)))) ;; USE: (lset-difference string=? '("a" "b" "c") '("d" "c" "e" "a")) ;; ;; Return a list of prereqs that were NOT met ;; Tests (and all items) in waiton list must be "COMPLETED" and "PASS" @@ -410,24 +499,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: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -145,11 +145,11 @@ (set! fullcmd (append launcher (list remote-megatest "-execute" cmdparms)))) (else (set! fullcmd (list remote-megatest "-execute" cmdparms)))) (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) (debug:print 1 "Launching megatest for test " test-name " in " work-area" ...") - (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat) ;; (if launch-results launch-results "FAILED")) + (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat #f #f) ;; (if launch-results launch-results "FAILED")) ;; set ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done (let* ((commonprevvals (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))) (testprevvals (alist->env-vars Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,1 +1,3 @@ -(define megatest-version 1.19) +;; Always use two digit decimal +;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. +(define megatest-version 1.21) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -37,10 +37,18 @@ Run data :runname : required, name for this particular test run :state : required if updating step state; e.g. start, end, completed :status : required if updating step status; e.g. pass, fail, n/a +Values and record errors and warnings + -set-values : update or set values in the megatest db + :value : value measured + :expected_value : value expected + :tol : tolerance |value-expect| <= tol + :first_err : record an error message + :first_warn : record a warning message + 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 @@ -54,10 +62,14 @@ -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 + -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 @@ -88,24 +100,37 @@ "-set-toplog" "-runstep" "-logpro" "-m" "-rerun" + "-days" + "-rename-run" + "-to" + ;; values and messages + ":first_err" + ":first_warn" + ":value" + ":expected_value" + ":tol" + ;; misc "-debug" ;; for *verbosity* > 2 ) (list "-h" "-force" "-xterm" "-showkeys" "-test-status" + "-set-values" "-summarize-items" "-gui" "-runall" ;; run all tests "-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)) @@ -258,31 +283,29 @@ ;; 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") - (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)))) + (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))))) ;;====================================================================== ;; run one test ;;====================================================================== @@ -297,35 +320,17 @@ ;; - 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") - (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))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host ;; - receives info from the -execute param @@ -371,11 +376,11 @@ (alist->env-vars env-ovrd) (set-megatest-env-vars db run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") (test-set-meta-info db run-id test-name itemdat) - (test-set-status! db run-id test-name "REMOTEHOSTSTART" "n/a" itemdat (args:get-arg "-m")) + (test-set-status! db run-id test-name "REMOTEHOSTSTART" "n/a" itemdat (args:get-arg "-m") #f) (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (not (file-execute-access? fullrunscript)) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test @@ -459,11 +464,11 @@ ;; (sqlite3:finalize! db) ;; (exit 1))))) (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") (test-set-status! db run-id test-name "KILLED" "FAIL" - itemdat (args:get-arg "-m")) + itemdat (args:get-arg "-m") #f) (sqlite3:finalize! db) (exit 1)))) ;; (thread-terminate! job-thread))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) @@ -503,13 +508,14 @@ (if (vector-ref exit-info 1) ;; look at the exit-status (if (and (not kill-job?) (eq? (vector-ref exit-info 2) 0)) "PASS" "FAIL") - "FAIL") itemdat (args:get-arg "-m")))) + "FAIL") itemdat (args:get-arg "-m") #f))) ;; for automated creation of the rollup html file this is a good place... - (tests:summarize-items db run-id test-name #f) ;; don't force - just update if no + (if (not (equal? item-path "")) + (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 " @@ -550,10 +556,11 @@ (set! *didsomething* #t)))) (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 "-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!") @@ -628,22 +635,33 @@ (if (not (eq? exitstat 0)) (exit 254)) ;; (exit exitstat) doesn't work?!? ;; open the db ;; mark the end of the test ))) - (if (args:get-arg "-test-status") + (if (or (args:get-arg "-test-status") + (args:get-arg "-set-values")) (let ((newstatus (cond ((number? status) (if (equal? status 0) "PASS" "FAIL")) - ((string->number status)(if (equal? (string->number status) 0) "PASS" "FAIL")) - (else status)))) - (test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m"))) - (if (and state status) - (if (not (args:get-arg "-setlog")) - (begin - (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) - (sqlite3:finalize! db) - (exit 6))))) + ((and (string? status) + (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL")) + (else status))) + ;; transfer relevant keys into a hash to be passed to test-set-status! + ;; could use an assoc list I guess. + (otherdata (let ((res (make-hash-table))) + (for-each (lambda (key) + (if (args:get-arg key) + (hash-table-set! res key (args:get-arg key)))) + (list ":value" ":tol" ":expected_value" ":first_err" ":first_warn")) + res))) + (if (and (args:get-arg "-test-status") + (or (not state) + (not status))) + (begin + (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) + (sqlite3:finalize! db) + (exit 6))) + (test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m") otherdata))) (sqlite3:finalize! db) (set! *didsomething* #t)))) (if (args:get-arg "-showkeys") (let ((db #f) @@ -677,10 +695,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)) ADDED mkcsv.sh Index: mkcsv.sh ================================================================== --- /dev/null +++ mkcsv.sh @@ -0,0 +1,21 @@ +#!/bin/sh + +sqlite3 megatest.db <path itemdat-or-path)))) - (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) - (if (and (not (equal? item-path "")) ;; need to update the top test record if PASS or FAIL and this is a subtest +(define (test-set-status! db run-id test-name state status itemdat-or-path comment dat) + (let ((item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path))) + (otherdat (if dat dat (make-hash-table)))) + ;; update the primary record IF state AND status are defined + (if (and state status) + (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)) + ;; add metadata (need to do this way to avoid SQL injection issues) + ;; :value + (let ((val (hash-table-ref/default otherdat ":value" #f))) + (if val + (sqlite3:execute db "UPDATE tests SET value=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) + ;; :expected_value + (let ((val (hash-table-ref/default otherdat ":expected_value" #f))) + (if val + (sqlite3:execute db "UPDATE tests SET expected_value=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) + ;; :tol + (let ((val (hash-table-ref/default otherdat ":tol" #f))) + (if val + (sqlite3:execute db "UPDATE tests SET tol=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) + ;; :first_err + (let ((val (hash-table-ref/default otherdat ":first_err" #f))) + (if val + (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) + ;; :first_warn + (let ((val (hash-table-ref/default otherdat ":first_warn" #f))) + (if val + (sqlite3:execute db "UPDATE tests SET first_warn=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) + ;; :tol_perc + (let ((val (hash-table-ref/default otherdat ":tol_perc" #f))) + (if val + (sqlite3:execute db "UPDATE tests SET tol_perc=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) + + ;; need to update the top test record if PASS or FAIL and this is a subtest + (if (and (not (equal? item-path "")) (or (equal? status "PASS") (equal? status "WARN") (equal? status "FAIL"))) (begin (sqlite3:execute @@ -114,14 +145,15 @@ '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 (and (not (null? comment)) - (car comment)) + (if (and (string? comment) + (string-match (regexp "\\S+") comment)) (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" - (car comment) run-id test-name item-path)))) + (car 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))) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" logf run-id test-name item-path))) @@ -400,15 +432,19 @@ (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 ",") '())))) + ;; we want our tags to be separated by commas and fully delimited by commas + ;; so that queries with "like" can tie to the commas at either end of each tag + ;; while also allowing the end user to freely use spaces and commas to separate tags + (if (string? t)(string-substitute (regexp "[,\\s]+") "," (conc "," t ",") #t) + '())))) (if (not testexists) (begin (debug:print 0 "ERROR: Can't find config file " test-configf) (exit 2)) ;; put top vars into convenient variables and open the db @@ -426,10 +462,14 @@ (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 + (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))) ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) @@ -449,11 +489,11 @@ (let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #f) (ct 0)) (if (and (not ts) (< ct 10)) (begin - (register-test db run-id test-name item-path tags) + (register-test db run-id test-name item-path) (db:test-set-comment db run-id test-name item-path "") (loop2 (db:get-test-info db run-id test-name item-path) (+ ct 1))) (if ts (set! testdat ts) @@ -633,5 +673,79 @@ ;; (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)))) + +;;====================================================================== +;; 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-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,5 +17,15 @@ 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 @@ -10,18 +10,19 @@ (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"))) ;; 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")) @@ -60,11 +61,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" "") + (register-test *db* 1 "nada" "" '("tag1" "tag2" "tag3")) (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/main.sh ================================================================== --- tests/tests/runfirst/main.sh +++ tests/tests/runfirst/main.sh @@ -6,6 +6,6 @@ touch ../I_was_here $MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 8;echo all done eh?" -m "This is a test step comment" -$MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" -set-toplog the_top_log.html +$MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" -set-toplog the_top_log.html :value 1e6 :expected_value 1.1e6 :tol 100e3 Index: tests/tests/runfirst/testconfig ================================================================== --- tests/tests/runfirst/testconfig +++ tests/tests/runfirst/testconfig @@ -12,5 +12,13 @@ [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 Index: tests/tests/singletest/main.sh ================================================================== --- tests/tests/singletest/main.sh +++ tests/tests/singletest/main.sh @@ -4,6 +4,6 @@ # sleep 20 # megatest -step wasting_time :state end :status $? $MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo all done eh?" -m "This is a test step comment" -$MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" -set-toplog the_top_log.html +$MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" -set-toplog the_top_log.html :first_err "This is the first error" Index: tests/tests/singletest2/main.sh ================================================================== --- tests/tests/singletest2/main.sh +++ tests/tests/singletest2/main.sh @@ -4,6 +4,6 @@ # sleep 20 # megatest -step wasting_time :state end :status $? $MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo all done eh?" -m "This is a test step comment" -$MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" -set-toplog the_top_log.html +$MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" -set-toplog the_top_log.html :first_warn "This is the first warning"