Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -2,11 +2,11 @@ PREFIX=. SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ - process.scm runs.scm tasks.scm + process.scm runs.scm tasks.scm tests.scm GUISRCF = dashboard.scm dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) @@ -24,10 +24,11 @@ # Special dependencies for the includes db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o monitor.o dashboard.o megatest.o : db_records.scm runs.o dashboard.o dashboard-tests.o : run_records.scm keys.o db.o runs.o launch.o megatest.o : key_records.scm tasks.o dashboard-tasks.o : task_records.scm +runs.o : old-runs.scm $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm csc -c $< Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -453,11 +453,12 @@ ;; (print "Setting search for " x " to " val) (hash-table-set! *searchpatts* x val)) (define (mark-for-update) (set! *last-db-update-time* 0) - (set! *delayed-update* 1)) + (set! *delayed-update* 1) + ) (define (make-dashboard-buttons nruns ntests keynames) (let* ((nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -117,10 +117,18 @@ '() #f))) res))) ;; Nope, not now, return null as of 6/6/2011 - +(define (check-valid-items class item) + (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class))) + (if s (string-split s) #f)))) + (if valid-values + (if (member item valid-values) + item #f) + item))) + + ;; (pp (item-assoc->item-list itemdat)) ADDED old-runs.scm Index: old-runs.scm ================================================================== --- /dev/null +++ old-runs.scm @@ -0,0 +1,305 @@ +;; register a test run with the db +(define (register-run db keys) ;; test-name) + (let* ((keystr (keys->keystr keys)) + (comma (if (> (length keys) 0) "," "")) + (andstr (if (> (length keys) 0) " AND " "")) + (valslots (keys->valslots keys)) ;; ?,?,? ... + (keyvallst (keys->vallist keys)) ;; extracts the values from remainder of (argv) + (runname (get-with-default ":runname" #f)) + (state (get-with-default ":state" "no")) + (status (get-with-default ":status" "n/a")) + (allvals (append (list runname state status user) keyvallst)) + (qryvals (append (list runname) keyvallst)) + (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) + (debug:print 3 "keys: " keys " allvals: " allvals " keyvallst: " keyvallst) + (debug:print 2 "NOTE: using key " (string-intersperse keyvallst "/") " for this run") + (if (and runname (null? (filter (lambda (x)(not x)) keyvallst))) ;; there must be a better way to "apply and" + (let ((res #f)) + (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") + allvals) + (apply sqlite3:for-each-row + (lambda (id) + (set! res id)) + db + (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) + ;(debug:print 4 "qry: " qry) + qry) + qryvals) + (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res) + res) + (begin + (debug:print 0 "ERROR: Called without all necessary keys") + #f)))) + +;; This is original run-tests, this routine is deprecated and we will transition to using runs:run-tests (see below) +;; +(define (run-tests db test-names) + (let* ((keys (db-get-keys db)) + (keyvallst (keys->vallist keys #t)) + (run-id (register-run db keys)) ;; test-name))) + (deferred '()) ;; delay running these since they have a waiton clause + (runconfigf (conc *toppath* "/runconfigs.config")) + (required-tests '())) + + ;; now add non-directly referenced dependencies (i.e. waiton) + ;; could cache all these since they need to be read again ... + ;; FIXME SOMEDAY + (if (not (null? test-names)) + (let loop ((hed (car test-names)) + (tal (cdr test-names))) + (let* ((config (test:get-testconfig hed #f)) + (waitons (string-split (let ((w (config-lookup config "requirements" "waiton"))) + (if w w ""))))) + (for-each + (lambda (waiton) + (if (and waiton (not (member waiton test-names))) + (begin + (set! required-tests (cons waiton required-tests)) + (set! test-names (append test-names (list waiton)))))) + waitons) + (let ((remtests (delete-duplicates (append waitons tal)))) + (if (not (null? remtests)) + (loop (car remtests)(cdr remtests))))))) + + (if (not (null? required-tests)) + (debug:print 1 "INFO: Adding " required-tests " to the run queue") + (debug:print 1 "INFO: No prerequisites added")) + + ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if + ;; -keepgoing is specified + + (set-megatest-env-vars db run-id) ;; these may be needed by the launching process + + (if (file-exists? runconfigf) + (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* environ-patt: ".*") + (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) + + (if (and (eq? *passnum* 0) + (args:get-arg "-keepgoing")) + (begin + ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to + ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends + ;; on test A but test B reached the point on being registered as NOT_STARTED and test + ;; A failed for some reason then on re-run using -keepgoing the run can never complete. + (db:delete-tests-in-state db run-id "NOT_STARTED") + (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + (set! *passnum* (+ *passnum* 1)) + (let loop ((numtimes 0)) + (for-each + (lambda (test-name) + (if (runs:can-run-more-tests db) + (run-one-test db run-id test-name keyvallst) + ;; add some delay + ;(sleep 2) + )) + (tests:sort-by-priority-and-waiton test-names)) + ;; (run-waiting-tests db) + (if (args:get-arg "-keepgoing") + (let ((estrem (db:estimated-tests-remaining db run-id))) + (if (and (> estrem 0) + (eq? *globalexitstatus* 0)) + (begin + (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...") + (thread-sleep! 3) + (run-waiting-tests db) + (loop (+ numtimes 1))))))))) + +;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc +(define (run-one-test db run-id test-name keyvallst) + (debug:print 1 "Launching test " test-name) + ;; All these vars might be referenced by the testconfig file reader + (setenv "MT_TEST_NAME" test-name) ;; + (setenv "MT_RUNNAME" (args:get-arg ":runname")) + + ;; (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)) ;; could use test:get-testconfig here ... + (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 #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"))) + ;; 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 + (let* (;; db is always at *toppath*/db/megatest.db + (items (hash-table-ref/default test-conf "items" '())) + (itemstable (hash-table-ref/default test-conf "itemstable" '())) + (allitems (if (or (not (null? items))(not (null? itemstable))) + (append (item-assoc->item-list items) + (item-table->item-list itemstable)) + '(())))) ;; a list with one null list is a test with no items +;; (runconfigf (conc *toppath* "/runconfigs.config"))) + (debug:print 1 "items: ") + (if (>= *verbosity* 1)(pp allitems)) + (if (>= *verbosity* 5) + (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")) + ;; Handle lists of items + (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/")) + (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) + (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique + (testdat #f) + (num-running (db:get-count-tests-running db)) + (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")) + (parent-test (and (not (null? items))(equal? item-path ""))) + (single-test (and (null? items) (equal? item-path ""))) + (item-test (not (equal? item-path ""))) + (item-patt (args:get-arg "-itempatt")) + (patt-match (if item-patt + (string-search (glob->regexp + (string-translate item-patt "%" "*")) + item-path) + #t))) + (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (if (and patt-match (runs:can-run-more-tests db)) + (begin + (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) + (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) + (begin + (debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping") + (if (not (null? tal)) + (loop (car tal)(cdr tal))))))) + (change-directory test-path) + ;; this block is here only to inform the user early on + + ;; NB// Moving the setting of runconfig.config vars to *before* the + ;; the calling of each test. + ;; (if (file-exists? runconfigf) + ;; (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) + ;; (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) + (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat)) + (case (if (args:get-arg "-force") + 'NOT_STARTED + (if testdat + (string->symbol (test:get-state testdat)) + 'failed-to-insert)) + ((failed-to-insert) + (debug:print 0 "ERROR: Failed to insert the record into the db")) + ((NOT_STARTED COMPLETED) + (debug:print 6 "Got here, " (test:get-state testdat)) + (let ((runflag #f)) + (cond + ;; i.e. this is the parent test to a suite of items, never "run" it + (parent-test + (set! runflag #f)) + ;; -force, run no matter what + ((args:get-arg "-force")(set! runflag #t)) + ;; NOT_STARTED, run no matter what + ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t)) + ;; not -rerun and PASS, WARN or CHECK, do no run + ((and (or (not (args:get-arg "-rerun")) + (args:get-arg "-keepgoing")) + (member (test:get-status testdat) '("PASS" "WARN" "CHECK"))) + (set! runflag #f)) + ;; -rerun and status is one of the specifed, run it + ((and (args:get-arg "-rerun") + (let ((rerunlst (string-split (args:get-arg "-rerun") ","))) ;; FAIL, + (member (test:get-status testdat) rerunlst))) + (set! runflag #t)) + ;; -keepgoing, do not rerun FAIL + ((and (args:get-arg "-keepgoing") + (member (test:get-status testdat) '("FAIL"))) + (set! runflag #f)) + ((and (not (args:get-arg "-rerun")) + (member (test:get-status testdat) '("FAIL" "n/a"))) + (set! runflag #t)) + (else (set! runflag #f))) + (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) + (if (not runflag) + (if (not parent-test) + (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override")) + (let* ((get-prereqs-cmd (lambda () + (db-get-prereqs-not-met db run-id waiton))) ;; check before running .... + (launch-cmd (lambda () + (launch-test db run-id (args:get-arg ":runname") test-conf keyvallst test-name test-path itemdat args:arg-hash))) + (testrundat (list get-prereqs-cmd launch-cmd))) + (if (or (args:get-arg "-force") + (let ((preqs-not-yet-met ((car testrundat)))) + (debug:print 2 "Preqrequesites for " test-name ": " preqs-not-yet-met) + (null? preqs-not-yet-met))) ;; are there any tests that must be run before this one... + (if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host + (begin + (print "ERROR: Failed to launch the test. Exiting as soon as possible") + (set! *globalexitstatus* 1) ;; + (process-signal (current-process-id) signal/kill) + ;(exit 1) + )) + (if (not (args:get-arg "-keepgoing")) + (hash-table-set! *waiting-queue* new-test-name testrundat))))))) + ((KILLED) + (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) + ((LAUNCHED REMOTEHOSTSTART RUNNING) + (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) + (db:test-get-run_duration testdat))) + 100) ;; i.e. no update for more than 100 seconds + (begin + (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") + (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead" #f)) + (debug:print 2 "NOTE: " test-name " is already running"))) + (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat)))))) + (if (not (null? tal)) + (loop (car tal)(cdr tal))))))))) + +(define (run-waiting-tests db) + (let ((numtries 0) + (last-try-time (current-seconds)) + (times (list 1))) ;; minutes to wait before trying again to kick off runs + ;; BUG this hack of brute force retrying works quite well for many cases but + ;; what is needed is to check the db for tests that have failed less than + ;; N times or never been started and kick them off again + (let loop ((waiting-test-names (hash-table-keys *waiting-queue*))) + (cond + ((not (runs:can-run-more-tests db)) + (thread-sleep! 2) + (loop waiting-test-names)) + ((null? waiting-test-names) + (debug:print 1 "All tests launched")) + (else + (set! numtries (+ numtries 1)) + (for-each (lambda (testname) + (if (runs:can-run-more-tests db) + (let* ((testdat (hash-table-ref *waiting-queue* testname)) + (prereqs ((car testdat))) + (ldb (if db db (open-db)))) + (debug:print 2 "prereqs remaining: " prereqs) + (if (null? prereqs) + (begin + (debug:print 2 "Prerequisites met, launching " testname) + ((cadr testdat)) + (hash-table-delete! *waiting-queue* testname))) + (if (not db) + (sqlite3:finalize! ldb))))) + waiting-test-names) + ;; (sleep 10) ;; no point in rushing things at this stage? + (loop (hash-table-keys *waiting-queue*))))))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -16,48 +16,20 @@ (declare (unit runs)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) +(declare (uses tests)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") -;; register a test run with the db -(define (register-run db keys) ;; test-name) - (let* ((keystr (keys->keystr keys)) - (comma (if (> (length keys) 0) "," "")) - (andstr (if (> (length keys) 0) " AND " "")) - (valslots (keys->valslots keys)) ;; ?,?,? ... - (keyvallst (keys->vallist keys)) ;; extracts the values from remainder of (argv) - (runname (get-with-default ":runname" #f)) - (state (get-with-default ":state" "no")) - (status (get-with-default ":status" "n/a")) - (allvals (append (list runname state status user) keyvallst)) - (qryvals (append (list runname) keyvallst)) - (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) - (debug:print 3 "keys: " keys " allvals: " allvals " keyvallst: " keyvallst) - (debug:print 2 "NOTE: using key " (string-intersperse keyvallst "/") " for this run") - (if (and runname (null? (filter (lambda (x)(not x)) keyvallst))) ;; there must be a better way to "apply and" - (let ((res #f)) - (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") - allvals) - (apply sqlite3:for-each-row - (lambda (id) - (set! res id)) - db - (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) - ;(debug:print 4 "qry: " qry) - qry) - qryvals) - (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res) - res) - (begin - (debug:print 0 "ERROR: Called without all necessary keys") - #f)))) +;; stuff to be deprecated then removed +(include "old-runs.scm") + ;; runs:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; @@ -87,298 +59,10 @@ db (conc "SELECT " keystr " FROM runs WHERE runname like ? " key-patt ";") runnamepatt) (vector header res))) -(define (register-test db run-id test-name item-path) - (let ((item-paths (if (equal? item-path "") - (list item-path) - (list item-path "")))) - (for-each - (lambda (pth) - (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" - run-id - test-name - pth - ;; (conc "," (string-intersperse tags ",") ",") - )) - item-paths ))) - -;; get the previous record for when this test was run where all keys match but runname -;; returns #f if no such test found, returns a single test record if found -(define (test:get-previous-test-run-record db run-id test-name item-path) - (let* ((keys (db:get-keys db)) - (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) - (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) - (keyvals #f)) - ;; first look up the key values from the run selected by run-id - (sqlite3:for-each-row - (lambda (a . b) - (set! keyvals (cons a b))) - db - (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) - (if (not keyvals) - #f - (let ((prev-run-ids '())) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) - ;; for each run starting with the most recent look to see if there is a matching test - ;; if found then return that matching test record - (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) - (if (null? prev-run-ids) #f - (let loop ((hed (car prev-run-ids)) - (tal (cdr prev-run-ids))) - (let ((results (db-get-tests-for-run db hed test-name item-path '() '()))) - (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) - (if (and (null? results) - (not (null? tal))) - (loop (car tal)(cdr tal)) - (if (null? results) #f - (car results)))))))))) - -;; get the previous records for when these tests were run where all keys match but runname -;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests -;; can use wildcards. -(define (test:get-matching-previous-test-run-records db run-id test-name item-path) - (let* ((keys (db:get-keys db)) - (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) - (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) - (keyvals #f) - (tests-hash (make-hash-table))) - ;; first look up the key values from the run selected by run-id - (sqlite3:for-each-row - (lambda (a . b) - (set! keyvals (cons a b))) - db - (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) - (if (not keyvals) - '() - (let ((prev-run-ids '())) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) - ;; collect all matching tests for the runs then - ;; extract the most recent test and return that. - (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals - ", previous run ids found: " prev-run-ids) - (if (null? prev-run-ids) '() ;; no previous runs? return null - (let loop ((hed (car prev-run-ids)) - (tal (cdr prev-run-ids))) - (let ((results (db-get-tests-for-run db hed test-name item-path '() '()))) - (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name - ", item-path " item-path " results: " (intersperse results "\n")) - ;; Keep only the youngest of any test/item combination - (for-each - (lambda (testdat) - (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) - (stored-test (hash-table-ref/default tests-hash full-testname #f))) - (if (or (not stored-test) - (and stored-test - (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) - ;; this test is younger, store it in the hash - (hash-table-set! tests-hash full-testname testdat)))) - results) - (if (null? tal) - (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests - (loop (car tal)(cdr tal)))))))))) - -(define (test-set-status! db run-id test-name state status itemdat-or-path comment dat) - (let* ((real-status status) - (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path))) - (testdat (db:get-test-info db run-id test-name item-path)) - (test-id (if testdat (db:test-get-id testdat) #f)) - (otherdat (if dat dat (make-hash-table))) - ;; before proceeding we must find out if the previous test (where all keys matched except runname) - ;; was WAIVED if this test is FAIL - (waived (if (equal? status "FAIL") - (let ((prev-test (test:get-previous-test-run-record db run-id test-name item-path))) - (if prev-test ;; true if we found a previous test in this run series - (let ((prev-status (db:test-get-status prev-test)) - (prev-state (db:test-get-state prev-test)) - (prev-comment (db:test-get-comment prev-test))) - (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) - (if (and (equal? prev-state "COMPLETED") - (equal? prev-status "WAIVED")) - prev-comment ;; waived is either the comment or #f - #f)) - #f)) - #f))) - (if waived (set! real-status "WAIVED")) - (debug:print 4 "real-status " real-status ", waived " waived ", status " status) - - ;; 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 real-status run-id test-name item-path)) - - ;; if status is "AUTO" then call rollup - (if (and test-id state status (equal? status "AUTO")) - (db:test-data-rollup db test-id)) - - ;; add metadata (need to do this way to avoid SQL injection issues) - - ;; :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))) - - (let ((category (hash-table-ref/default otherdat ":category" "")) - (variable (hash-table-ref/default otherdat ":variable" "")) - (value (hash-table-ref/default otherdat ":value" #f)) - (expected (hash-table-ref/default otherdat ":expected" #f)) - (tol (hash-table-ref/default otherdat ":tol" #f)) - (units (hash-table-ref/default otherdat ":units" "")) - (dcomment (hash-table-ref/default otherdat ":comment" ""))) - (debug:print 4 - "category: " category ", variable: " variable ", value: " value - ", expected: " expected ", tol: " tol ", units: " units) - (if (and value expected tol) ;; all three required - (db:csv->test-data db test-id - (conc category "," - variable "," - value "," - expected "," - tol "," - units "," - dcomment ",")))) - - ;; 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") - (equal? status "WAIVED") - (equal? status "RUNNING"))) - (begin - (sqlite3:execute - db - "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'), - pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED')) - WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name run-id test-name run-id test-name) - (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING - (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" run-id test-name) - (sqlite3:execute - db - "UPDATE tests - SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN - '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 (or (and (string? comment) - (string-match (regexp "\\S+") comment)) - waived) - (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" - (if waived waived 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))) - -(define (test-set-toplog! db run-id test-name logf) - (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" - logf run-id test-name)) - -(define (tests:summarize-items db run-id test-name force) - ;; if not force then only update the record if one of these is true: - ;; 1. logf is "log/final.log - ;; 2. logf is same as outputfilename - (let ((outputfilename (conc "megatest-rollup-" test-name ".html")) - (orig-dir (current-directory)) - (logf #f)) - (sqlite3:for-each-row - (lambda (path final_logf) - (set! logf final_logf) - (if (directory? path) - (begin - (print "Found path: " path) - (change-directory path)) - ;; (set! outputfilename (conc path "/" outputfilename))) - (print "No such path: " path))) - db - "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name) - (print "summarize-items with logf " logf) - (if (or (equal? logf "logs/final.log") - (equal? logf outputfilename) - force) - (begin - (if (obtain-dot-lock outputfilename 1 20 30) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock - (print "Obtained lock for " outputfilename) - (print "Failed to obtain lock for " outputfilename)) - (let ((oup (open-output-file outputfilename)) - (counts (make-hash-table)) - (statecounts (make-hash-table)) - (outtxt "") - (tot 0)) - (with-output-to-port - oup - (lambda () - (set! outtxt (conc outtxt "Summary: " test-name - "

Summary for " test-name "

")) - (sqlite3:for-each-row - (lambda (id itempath state status run_duration logf comment) - (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) - (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) - (set! outtxt (conc outtxt "" - " " itempath "" - "" state "" - "" status "" - "" (if (equal? comment "") - " " - comment) "" - ""))) - db - "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';" - run-id test-name) - - (print "
") - ;; Print out stats for status - (set! tot 0) - (print "") - (for-each (lambda (state) - (set! tot (+ tot (hash-table-ref statecounts state))) - (print "")) - (hash-table-keys statecounts)) - (print "

State stats

" state "" (hash-table-ref statecounts state) "
Total" tot "
") - (print "		") - ;; Print out stats for state - (set! tot 0) - (print "") - (for-each (lambda (status) - (set! tot (+ tot (hash-table-ref counts status))) - (print "")) - (hash-table-keys counts)) - (print "

Status stats

" status - "" (hash-table-ref counts status) "
Total" tot "
") - (print "
") - - (print "" - "" - outtxt "
ItemStateStatusComment
") - (release-dot-lock outputfilename))) - (close-output-port oup) - (change-directory orig-dir) - (test-set-toplog! db run-id test-name outputfilename) - ))))) - ;; ;; TODO: Converge this with db:get-test-info ;; (define (runs:get-test-info db run-id test-name item-path) ;; (let ((res #f)) ;; (vector #f #f #f #f #f #f))) ;; (sqlite3:for-each-row ;; (lambda (id run-id test-name state status) @@ -390,74 +74,10 @@ (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) -(define (check-valid-items class item) - (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class))) - (if s (string-split s) #f)))) - (if valid-values - (if (member item valid-values) - item #f) - item))) - -(define (teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile) - (debug:print 4 "run-id: " run-id " test-name: " test-name) - (let* ((state (check-valid-items "state" state-in)) - (status (check-valid-items "status" status-in)) - (item-path (item-list->path itemdat)) - (testdat (db:get-test-info db run-id test-name item-path))) - (debug:print 5 "testdat: " testdat) - (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works. - (or (not state)(not status))) - (debug:print 0 "WARNING: Invalid " (if status "status" "state") - " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (if testdat - (let ((test-id (test:get-id testdat))) - ;; FIXME - this should not update the logfile unless it is specified. - (sqlite3:execute db - "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,strftime('%s','now'),?,?);" - test-id teststep-name state-in status-in (if comment comment "") (if logfile logfile ""))) - (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db")))) - -(define (test-get-kill-request 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))) - (equal? (test:get-state testdat) "KILLREQ"))) - -(define (test-set-meta-info db run-id testname itemdat) - (let ((item-path (item-list->path itemdat)) - (cpuload (get-cpu-load)) - (hostname (get-host-name)) - (diskfree (get-df (current-directory))) - (uname (get-uname "-srvpio")) - (runpath (current-directory))) - (sqlite3:execute db "UPDATE tests SET host=?,cpuload=?,diskfree=?,uname=?,rundir=? WHERE run_id=? AND testname=? AND item_path=?;" - hostname - cpuload - diskfree - uname - runpath - run-id - testname - item-path))) - -(define (test-update-meta-info db run-id testname itemdat minutes cpuload diskfree tmpfree) - (let ((item-path (item-list->path itemdat))) - (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (set! item-path ""))) - ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) - ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) - ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) - (sqlite3:execute - db - "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');" - cpuload - diskfree - minutes - run-id - testname - item-path))) (define (set-megatest-env-vars db run-id) (let ((keys (db-get-keys db))) (for-each (lambda (key) (sqlite3:for-each-row @@ -473,20 +93,10 @@ (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) itemdat)) -(define (get-all-legal-tests) - (let* ((tests (glob (conc *toppath* "/tests/*"))) - (res '())) - (debug:print 4 "INFO: Looking at tests " (string-intersperse tests ",")) - (for-each (lambda (testpath) - (if (file-exists? (conc testpath "/testconfig")) - (set! res (cons (last (string-split testpath "/")) res)))) - tests) - res)) - (define (runs:can-run-more-tests db) (let ((num-running (db:get-count-tests-running db)) (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))) (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (if (not (eq? 0 *globalexitstatus*)) @@ -499,322 +109,10 @@ (begin (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running ", max_concurrent_jobs: " max-concurrent-jobs) #f))))) -(define (test:get-testconfig test-name system-allowed) - (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)))) - (if testexists - (read-config test-configf #f system-allowed environ-patt: (if system-allowed - "pre-launch-env-vars" - #f)) - #f))) - -;; sort tests by priority and waiton -;; Move test specific stuff to a test unit FIXME one of these days -(define (tests:sort-by-priority-and-waiton test-names) - (let ((testdetails (make-hash-table)) - (mungepriority (lambda (priority) - (if priority - (let ((tmp (any->number priority))) - (if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0))) - 0)))) - (for-each (lambda (test-name) - (let ((test-config (test:get-testconfig test-name #f))) - (if test-config (hash-table-set! testdetails test-name test-config)))) - test-names) - (sort - (hash-table-keys testdetails) ;; avoid dealing with deleted tests, look at the hash table - (lambda (a b) - (let* ((tconf-a (hash-table-ref testdetails a)) - (tconf-b (hash-table-ref testdetails b)) - (a-waiton (config-lookup tconf-a "requirements" "waiton")) - (b-waiton (config-lookup tconf-b "requirements" "waiton")) - (a-priority (mungepriority (config-lookup tconf-a "requirements" "priority"))) - (b-priority (mungepriority (config-lookup tconf-b "requirements" "priority")))) - (if (and a-waiton (equal? a-waiton b)) - #f ;; cannot have a which is waiting on b happening before b - (if (and b-waiton (equal? b-waiton a)) - #t ;; this is the correct order, b is waiting on a and b is before a - (if (> a-priority b-priority) - #t ;; if a is a higher priority than b then we are good to go - #f)))))))) - -;; This is original run-tests, this routine is deprecated and we will transition to using runs:run-tests (see below) -;; -(define (run-tests db test-names) - (let* ((keys (db-get-keys db)) - (keyvallst (keys->vallist keys #t)) - (run-id (register-run db keys)) ;; test-name))) - (deferred '()) ;; delay running these since they have a waiton clause - (runconfigf (conc *toppath* "/runconfigs.config")) - (required-tests '())) - - ;; now add non-directly referenced dependencies (i.e. waiton) - ;; could cache all these since they need to be read again ... - ;; FIXME SOMEDAY - (if (not (null? test-names)) - (let loop ((hed (car test-names)) - (tal (cdr test-names))) - (let* ((config (test:get-testconfig hed #f)) - (waitons (string-split (let ((w (config-lookup config "requirements" "waiton"))) - (if w w ""))))) - (for-each - (lambda (waiton) - (if (and waiton (not (member waiton test-names))) - (begin - (set! required-tests (cons waiton required-tests)) - (set! test-names (append test-names (list waiton)))))) - waitons) - (let ((remtests (delete-duplicates (append waitons tal)))) - (if (not (null? remtests)) - (loop (car remtests)(cdr remtests))))))) - - (if (not (null? required-tests)) - (debug:print 1 "INFO: Adding " required-tests " to the run queue") - (debug:print 1 "INFO: No prerequisites added")) - - ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if - ;; -keepgoing is specified - - (set-megatest-env-vars db run-id) ;; these may be needed by the launching process - - (if (file-exists? runconfigf) - (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* environ-patt: ".*") - (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) - - (if (and (eq? *passnum* 0) - (args:get-arg "-keepgoing")) - (begin - ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to - ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends - ;; on test A but test B reached the point on being registered as NOT_STARTED and test - ;; A failed for some reason then on re-run using -keepgoing the run can never complete. - (db:delete-tests-in-state db run-id "NOT_STARTED") - (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) - (set! *passnum* (+ *passnum* 1)) - (let loop ((numtimes 0)) - (for-each - (lambda (test-name) - (if (runs:can-run-more-tests db) - (run-one-test db run-id test-name keyvallst) - ;; add some delay - ;(sleep 2) - )) - (tests:sort-by-priority-and-waiton test-names)) - ;; (run-waiting-tests db) - (if (args:get-arg "-keepgoing") - (let ((estrem (db:estimated-tests-remaining db run-id))) - (if (and (> estrem 0) - (eq? *globalexitstatus* 0)) - (begin - (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...") - (thread-sleep! 3) - (run-waiting-tests db) - (loop (+ numtimes 1))))))))) - -;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc -(define (run-one-test db run-id test-name keyvallst) - (debug:print 1 "Launching test " test-name) - ;; All these vars might be referenced by the testconfig file reader - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_RUNNAME" (args:get-arg ":runname")) - - ;; (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)) ;; could use test:get-testconfig here ... - (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 #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"))) - ;; 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 - (let* (;; db is always at *toppath*/db/megatest.db - (items (hash-table-ref/default test-conf "items" '())) - (itemstable (hash-table-ref/default test-conf "itemstable" '())) - (allitems (if (or (not (null? items))(not (null? itemstable))) - (append (item-assoc->item-list items) - (item-table->item-list itemstable)) - '(())))) ;; a list with one null list is a test with no items -;; (runconfigf (conc *toppath* "/runconfigs.config"))) - (debug:print 1 "items: ") - (if (>= *verbosity* 1)(pp allitems)) - (if (>= *verbosity* 5) - (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")) - ;; Handle lists of items - (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/")) - (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) - (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique - (testdat #f) - (num-running (db:get-count-tests-running db)) - (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")) - (parent-test (and (not (null? items))(equal? item-path ""))) - (single-test (and (null? items) (equal? item-path ""))) - (item-test (not (equal? item-path ""))) - (item-patt (args:get-arg "-itempatt")) - (patt-match (if item-patt - (string-search (glob->regexp - (string-translate item-patt "%" "*")) - item-path) - #t))) - (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) - (if (and patt-match (runs:can-run-more-tests db)) - (begin - (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) - (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) - (begin - (debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping") - (if (not (null? tal)) - (loop (car tal)(cdr tal))))))) - (change-directory test-path) - ;; this block is here only to inform the user early on - - ;; NB// Moving the setting of runconfig.config vars to *before* the - ;; the calling of each test. - ;; (if (file-exists? runconfigf) - ;; (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) - ;; (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) - (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat)) - (case (if (args:get-arg "-force") - 'NOT_STARTED - (if testdat - (string->symbol (test:get-state testdat)) - 'failed-to-insert)) - ((failed-to-insert) - (debug:print 0 "ERROR: Failed to insert the record into the db")) - ((NOT_STARTED COMPLETED) - (debug:print 6 "Got here, " (test:get-state testdat)) - (let ((runflag #f)) - (cond - ;; i.e. this is the parent test to a suite of items, never "run" it - (parent-test - (set! runflag #f)) - ;; -force, run no matter what - ((args:get-arg "-force")(set! runflag #t)) - ;; NOT_STARTED, run no matter what - ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t)) - ;; not -rerun and PASS, WARN or CHECK, do no run - ((and (or (not (args:get-arg "-rerun")) - (args:get-arg "-keepgoing")) - (member (test:get-status testdat) '("PASS" "WARN" "CHECK"))) - (set! runflag #f)) - ;; -rerun and status is one of the specifed, run it - ((and (args:get-arg "-rerun") - (let ((rerunlst (string-split (args:get-arg "-rerun") ","))) ;; FAIL, - (member (test:get-status testdat) rerunlst))) - (set! runflag #t)) - ;; -keepgoing, do not rerun FAIL - ((and (args:get-arg "-keepgoing") - (member (test:get-status testdat) '("FAIL"))) - (set! runflag #f)) - ((and (not (args:get-arg "-rerun")) - (member (test:get-status testdat) '("FAIL" "n/a"))) - (set! runflag #t)) - (else (set! runflag #f))) - (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) - (if (not runflag) - (if (not parent-test) - (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override")) - (let* ((get-prereqs-cmd (lambda () - (db-get-prereqs-not-met db run-id waiton))) ;; check before running .... - (launch-cmd (lambda () - (launch-test db run-id (args:get-arg ":runname") test-conf keyvallst test-name test-path itemdat args:arg-hash))) - (testrundat (list get-prereqs-cmd launch-cmd))) - (if (or (args:get-arg "-force") - (let ((preqs-not-yet-met ((car testrundat)))) - (debug:print 2 "Preqrequesites for " test-name ": " preqs-not-yet-met) - (null? preqs-not-yet-met))) ;; are there any tests that must be run before this one... - (if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host - (begin - (print "ERROR: Failed to launch the test. Exiting as soon as possible") - (set! *globalexitstatus* 1) ;; - (process-signal (current-process-id) signal/kill) - ;(exit 1) - )) - (if (not (args:get-arg "-keepgoing")) - (hash-table-set! *waiting-queue* new-test-name testrundat))))))) - ((KILLED) - (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) - ((LAUNCHED REMOTEHOSTSTART RUNNING) - (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) - (db:test-get-run_duration testdat))) - 100) ;; i.e. no update for more than 100 seconds - (begin - (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") - (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead" #f)) - (debug:print 2 "NOTE: " test-name " is already running"))) - (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat)))))) - (if (not (null? tal)) - (loop (car tal)(cdr tal))))))))) - -(define (run-waiting-tests db) - (let ((numtries 0) - (last-try-time (current-seconds)) - (times (list 1))) ;; minutes to wait before trying again to kick off runs - ;; BUG this hack of brute force retrying works quite well for many cases but - ;; what is needed is to check the db for tests that have failed less than - ;; N times or never been started and kick them off again - (let loop ((waiting-test-names (hash-table-keys *waiting-queue*))) - (cond - ((not (runs:can-run-more-tests db)) - (thread-sleep! 2) - (loop waiting-test-names)) - ((null? waiting-test-names) - (debug:print 1 "All tests launched")) - (else - (set! numtries (+ numtries 1)) - (for-each (lambda (testname) - (if (runs:can-run-more-tests db) - (let* ((testdat (hash-table-ref *waiting-queue* testname)) - (prereqs ((car testdat))) - (ldb (if db db (open-db)))) - (debug:print 2 "prereqs remaining: " prereqs) - (if (null? prereqs) - (begin - (debug:print 2 "Prerequisites met, launching " testname) - ((cadr testdat)) - (hash-table-delete! *waiting-queue* testname))) - (if (not db) - (sqlite3:finalize! ldb))))) - waiting-test-names) - ;; (sleep 10) ;; no point in rushing things at this stage? - (loop (hash-table-keys *waiting-queue*))))))) ;;====================================================================== ;; New methodology. These routines will replace the above in time. For ;; now the code is duplicated. This stuff is initially used in the monitor ;; based code. ADDED tests.scm Index: tests.scm ================================================================== --- /dev/null +++ tests.scm @@ -0,0 +1,415 @@ +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit tests)) +(declare (uses db)) +(declare (uses common)) +(declare (uses items)) +(declare (uses runconfig)) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") + + +(define (register-test db run-id test-name item-path) + (let ((item-paths (if (equal? item-path "") + (list item-path) + (list item-path "")))) + (for-each + (lambda (pth) + (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" + run-id + test-name + pth + ;; (conc "," (string-intersperse tags ",") ",") + )) + item-paths ))) + +;; get the previous record for when this test was run where all keys match but runname +;; returns #f if no such test found, returns a single test record if found +(define (test:get-previous-test-run-record db run-id test-name item-path) + (let* ((keys (db:get-keys db)) + (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) + (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) + (keyvals #f)) + ;; first look up the key values from the run selected by run-id + (sqlite3:for-each-row + (lambda (a . b) + (set! keyvals (cons a b))) + db + (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) + (if (not keyvals) + #f + (let ((prev-run-ids '())) + (apply sqlite3:for-each-row + (lambda (id) + (set! prev-run-ids (cons id prev-run-ids))) + db + (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) + ;; for each run starting with the most recent look to see if there is a matching test + ;; if found then return that matching test record + (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) + (if (null? prev-run-ids) #f + (let loop ((hed (car prev-run-ids)) + (tal (cdr prev-run-ids))) + (let ((results (db-get-tests-for-run db hed test-name item-path '() '()))) + (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) + (if (and (null? results) + (not (null? tal))) + (loop (car tal)(cdr tal)) + (if (null? results) #f + (car results)))))))))) + +;; get the previous records for when these tests were run where all keys match but runname +;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests +;; can use wildcards. +(define (test:get-matching-previous-test-run-records db run-id test-name item-path) + (let* ((keys (db:get-keys db)) + (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) + (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) + (keyvals #f) + (tests-hash (make-hash-table))) + ;; first look up the key values from the run selected by run-id + (sqlite3:for-each-row + (lambda (a . b) + (set! keyvals (cons a b))) + db + (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) + (if (not keyvals) + '() + (let ((prev-run-ids '())) + (apply sqlite3:for-each-row + (lambda (id) + (set! prev-run-ids (cons id prev-run-ids))) + db + (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) + ;; collect all matching tests for the runs then + ;; extract the most recent test and return that. + (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals + ", previous run ids found: " prev-run-ids) + (if (null? prev-run-ids) '() ;; no previous runs? return null + (let loop ((hed (car prev-run-ids)) + (tal (cdr prev-run-ids))) + (let ((results (db-get-tests-for-run db hed test-name item-path '() '()))) + (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name + ", item-path " item-path " results: " (intersperse results "\n")) + ;; Keep only the youngest of any test/item combination + (for-each + (lambda (testdat) + (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) + (stored-test (hash-table-ref/default tests-hash full-testname #f))) + (if (or (not stored-test) + (and stored-test + (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) + ;; this test is younger, store it in the hash + (hash-table-set! tests-hash full-testname testdat)))) + results) + (if (null? tal) + (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests + (loop (car tal)(cdr tal)))))))))) + +(define (test-set-status! db run-id test-name state status itemdat-or-path comment dat) + (let* ((real-status status) + (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path))) + (testdat (db:get-test-info db run-id test-name item-path)) + (test-id (if testdat (db:test-get-id testdat) #f)) + (otherdat (if dat dat (make-hash-table))) + ;; before proceeding we must find out if the previous test (where all keys matched except runname) + ;; was WAIVED if this test is FAIL + (waived (if (equal? status "FAIL") + (let ((prev-test (test:get-previous-test-run-record db run-id test-name item-path))) + (if prev-test ;; true if we found a previous test in this run series + (let ((prev-status (db:test-get-status prev-test)) + (prev-state (db:test-get-state prev-test)) + (prev-comment (db:test-get-comment prev-test))) + (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) + (if (and (equal? prev-state "COMPLETED") + (equal? prev-status "WAIVED")) + prev-comment ;; waived is either the comment or #f + #f)) + #f)) + #f))) + (if waived (set! real-status "WAIVED")) + (debug:print 4 "real-status " real-status ", waived " waived ", status " status) + + ;; 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 real-status run-id test-name item-path)) + + ;; if status is "AUTO" then call rollup + (if (and test-id state status (equal? status "AUTO")) + (db:test-data-rollup db test-id)) + + ;; add metadata (need to do this way to avoid SQL injection issues) + + ;; :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))) + + (let ((category (hash-table-ref/default otherdat ":category" "")) + (variable (hash-table-ref/default otherdat ":variable" "")) + (value (hash-table-ref/default otherdat ":value" #f)) + (expected (hash-table-ref/default otherdat ":expected" #f)) + (tol (hash-table-ref/default otherdat ":tol" #f)) + (units (hash-table-ref/default otherdat ":units" "")) + (dcomment (hash-table-ref/default otherdat ":comment" ""))) + (debug:print 4 + "category: " category ", variable: " variable ", value: " value + ", expected: " expected ", tol: " tol ", units: " units) + (if (and value expected tol) ;; all three required + (db:csv->test-data db test-id + (conc category "," + variable "," + value "," + expected "," + tol "," + units "," + dcomment ",")))) + + ;; 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") + (equal? status "WAIVED") + (equal? status "RUNNING"))) + (begin + (sqlite3:execute + db + "UPDATE tests + SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'), + pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED')) + WHERE run_id=? AND testname=? AND item_path='';" + run-id test-name run-id test-name run-id test-name) + (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING + (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" run-id test-name) + (sqlite3:execute + db + "UPDATE tests + SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN + '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 (or (and (string? comment) + (string-match (regexp "\\S+") comment)) + waived) + (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" + (if waived waived 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))) + +(define (test-set-toplog! db run-id test-name logf) + (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" + logf run-id test-name)) + +(define (tests:summarize-items db run-id test-name force) + ;; if not force then only update the record if one of these is true: + ;; 1. logf is "log/final.log + ;; 2. logf is same as outputfilename + (let ((outputfilename (conc "megatest-rollup-" test-name ".html")) + (orig-dir (current-directory)) + (logf #f)) + (sqlite3:for-each-row + (lambda (path final_logf) + (set! logf final_logf) + (if (directory? path) + (begin + (print "Found path: " path) + (change-directory path)) + ;; (set! outputfilename (conc path "/" outputfilename))) + (print "No such path: " path))) + db + "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';" + run-id test-name) + (print "summarize-items with logf " logf) + (if (or (equal? logf "logs/final.log") + (equal? logf outputfilename) + force) + (begin + (if (obtain-dot-lock outputfilename 1 20 30) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock + (print "Obtained lock for " outputfilename) + (print "Failed to obtain lock for " outputfilename)) + (let ((oup (open-output-file outputfilename)) + (counts (make-hash-table)) + (statecounts (make-hash-table)) + (outtxt "") + (tot 0)) + (with-output-to-port + oup + (lambda () + (set! outtxt (conc outtxt "Summary: " test-name + "

Summary for " test-name "

")) + (sqlite3:for-each-row + (lambda (id itempath state status run_duration logf comment) + (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) + (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) + (set! outtxt (conc outtxt "" + " " itempath "" + "" state "" + "" status "" + "" (if (equal? comment "") + " " + comment) "" + ""))) + db + "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';" + run-id test-name) + + (print "
") + ;; Print out stats for status + (set! tot 0) + (print "") + (for-each (lambda (state) + (set! tot (+ tot (hash-table-ref statecounts state))) + (print "")) + (hash-table-keys statecounts)) + (print "

State stats

" state "" (hash-table-ref statecounts state) "
Total" tot "
") + (print "		") + ;; Print out stats for state + (set! tot 0) + (print "") + (for-each (lambda (status) + (set! tot (+ tot (hash-table-ref counts status))) + (print "")) + (hash-table-keys counts)) + (print "

Status stats

" status + "" (hash-table-ref counts status) "
Total" tot "
") + (print "
") + + (print "" + "" + outtxt "
ItemStateStatusComment
") + (release-dot-lock outputfilename))) + (close-output-port oup) + (change-directory orig-dir) + (test-set-toplog! db run-id test-name outputfilename) + ))))) + +(define (get-all-legal-tests) + (let* ((tests (glob (conc *toppath* "/tests/*"))) + (res '())) + (debug:print 4 "INFO: Looking at tests " (string-intersperse tests ",")) + (for-each (lambda (testpath) + (if (file-exists? (conc testpath "/testconfig")) + (set! res (cons (last (string-split testpath "/")) res)))) + tests) + res)) + +(define (test:get-testconfig test-name system-allowed) + (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)))) + (if testexists + (read-config test-configf #f system-allowed environ-patt: (if system-allowed + "pre-launch-env-vars" + #f)) + #f))) + +;; sort tests by priority and waiton +;; Move test specific stuff to a test unit FIXME one of these days +(define (tests:sort-by-priority-and-waiton test-names) + (let ((testdetails (make-hash-table)) + (mungepriority (lambda (priority) + (if priority + (let ((tmp (any->number priority))) + (if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0))) + 0)))) + (for-each (lambda (test-name) + (let ((test-config (test:get-testconfig test-name #f))) + (if test-config (hash-table-set! testdetails test-name test-config)))) + test-names) + (sort + (hash-table-keys testdetails) ;; avoid dealing with deleted tests, look at the hash table + (lambda (a b) + (let* ((tconf-a (hash-table-ref testdetails a)) + (tconf-b (hash-table-ref testdetails b)) + (a-waiton (config-lookup tconf-a "requirements" "waiton")) + (b-waiton (config-lookup tconf-b "requirements" "waiton")) + (a-priority (mungepriority (config-lookup tconf-a "requirements" "priority"))) + (b-priority (mungepriority (config-lookup tconf-b "requirements" "priority")))) + (if (and a-waiton (equal? a-waiton b)) + #f ;; cannot have a which is waiting on b happening before b + (if (and b-waiton (equal? b-waiton a)) + #t ;; this is the correct order, b is waiting on a and b is before a + (if (> a-priority b-priority) + #t ;; if a is a higher priority than b then we are good to go + #f)))))))) + + +;;====================================================================== +;; test steps +;;====================================================================== + +(define (teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile) + (debug:print 4 "run-id: " run-id " test-name: " test-name) + (let* ((state (check-valid-items "state" state-in)) + (status (check-valid-items "status" status-in)) + (item-path (item-list->path itemdat)) + (testdat (db:get-test-info db run-id test-name item-path))) + (debug:print 5 "testdat: " testdat) + (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works. + (or (not state)(not status))) + (debug:print 0 "WARNING: Invalid " (if status "status" "state") + " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) + (if testdat + (let ((test-id (test:get-id testdat))) + ;; FIXME - this should not update the logfile unless it is specified. + (sqlite3:execute db + "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,strftime('%s','now'),?,?);" + test-id teststep-name state-in status-in (if comment comment "") (if logfile logfile ""))) + (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db")))) + +(define (test-get-kill-request 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))) + (equal? (test:get-state testdat) "KILLREQ"))) + +(define (test-set-meta-info db run-id testname itemdat) + (let ((item-path (item-list->path itemdat)) + (cpuload (get-cpu-load)) + (hostname (get-host-name)) + (diskfree (get-df (current-directory))) + (uname (get-uname "-srvpio")) + (runpath (current-directory))) + (sqlite3:execute db "UPDATE tests SET host=?,cpuload=?,diskfree=?,uname=?,rundir=? WHERE run_id=? AND testname=? AND item_path=?;" + hostname + cpuload + diskfree + uname + runpath + run-id + testname + item-path))) + +(define (test-update-meta-info db run-id testname itemdat minutes cpuload diskfree tmpfree) + (let ((item-path (item-list->path itemdat))) + (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (set! item-path ""))) + ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) + ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) + ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) + (sqlite3:execute + db + "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');" + cpuload + diskfree + minutes + run-id + testname + item-path))) +