Check-in [47e2caaf9c]
Not logged in
Overview
SHA1 Hash:47e2caaf9c3623f09cd261fd7d0f61cc51325ad0
Date: 2011-11-16 21:31:41
User: matt
Comment:Reorg'd code worked fine. Pulling the basic reorg back to trunk. Next batch of changes won't be so kind :)
Timelines: family | ancestors | descendants | both | trunk
Downloads: Tarball | ZIP archive
Other Links: files | file ages | manifest
Tags And Properties
Changes

Modified Makefile from [ecff33bacbf831e0] to [ed1fd098c50a8f43].

1 1 2 PREFIX=. 2 PREFIX=. 3 3 4 SRCFILES = common.scm items.scm launch.scm \ 4 SRCFILES = common.scm items.scm launch.scm \ 5 ods.scm runconfig.scm server.scm configf.scm \ 5 ods.scm runconfig.scm server.scm configf.scm \ 6 db.scm keys.scm margs.scm megatest-version.scm \ 6 db.scm keys.scm margs.scm megatest-version.scm \ 7 process.scm runs.scm tasks.scm | 7 process.scm runs.scm tasks.scm tests.scm 8 8 9 GUISRCF = dashboard.scm dashboard-tests.scm dashboard-guimonitor.scm 9 GUISRCF = dashboard.scm dashboard-tests.scm dashboard-guimonitor.scm 10 10 11 OFILES = $(SRCFILES:%.scm=%.o) 11 OFILES = $(SRCFILES:%.scm=%.o) 12 GOFILES = $(GUISRCF:%.scm=%.o) 12 GOFILES = $(GUISRCF:%.scm=%.o) 13 13 14 HELPERS=$(addprefix $(PREFIX)/bin/,mt_laststep mt_runstep mt_ezstep) 14 HELPERS=$(addprefix $(PREFIX)/bin/,mt_laststep mt_runstep mt_ezstep) ................................................................................................................................................................................ 22 csc $(OFILES) $(GOFILES) -o dboard 22 csc $(OFILES) $(GOFILES) -o dboard 23 23 24 # Special dependencies for the includes 24 # Special dependencies for the includes 25 db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o monitor.o dashboar 25 db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o monitor.o dashboar 26 runs.o dashboard.o dashboard-tests.o : run_records.scm 26 runs.o dashboard.o dashboard-tests.o : run_records.scm 27 keys.o db.o runs.o launch.o megatest.o : key_records.scm 27 keys.o db.o runs.o launch.o megatest.o : key_records.scm 28 tasks.o dashboard-tasks.o : task_records.scm 28 tasks.o dashboard-tasks.o : task_records.scm > 29 runs.o : old-runs.scm 29 30 30 $(OFILES) $(GOFILES) : common_records.scm 31 $(OFILES) $(GOFILES) : common_records.scm 31 32 32 %.o : %.scm 33 %.o : %.scm 33 csc -c $< 34 csc -c $< 34 35 35 $(PREFIX)/bin/megatest : megatest 36 $(PREFIX)/bin/megatest : megatest

Modified dashboard.scm from [55452f0f205359b0] to [16c17747cc81e552].

451 451 452 (define (update-search x val) 452 (define (update-search x val) 453 ;; (print "Setting search for " x " to " val) 453 ;; (print "Setting search for " x " to " val) 454 (hash-table-set! *searchpatts* x val)) 454 (hash-table-set! *searchpatts* x val)) 455 455 456 (define (mark-for-update) 456 (define (mark-for-update) 457 (set! *last-db-update-time* 0) 457 (set! *last-db-update-time* 0) 458 (set! *delayed-update* 1)) | 458 (set! *delayed-update* 1) > 459 ) 459 460 460 (define (make-dashboard-buttons nruns ntests keynames) 461 (define (make-dashboard-buttons nruns ntests keynames) 461 (let* ((nkeys (length keynames)) 462 (let* ((nkeys (length keynames)) 462 (runsvec (make-vector nruns)) 463 (runsvec (make-vector nruns)) 463 (header (make-vector nruns)) 464 (header (make-vector nruns)) 464 (lftcol (make-vector ntests)) 465 (lftcol (make-vector ntests)) 465 (keycol (make-vector ntests)) 466 (keycol (make-vector ntests))

Modified items.scm from [efcc75596f0f06d5] to [24c226214482b949].

114 (begin 114 (begin 115 (set! res (append res (list item))) 115 (set! res (append res (list item))) 116 (loop (+ indx 1) 116 (loop (+ indx 1) 117 '() 117 '() 118 #f))) 118 #f))) 119 res))) 119 res))) 120 ;; Nope, not now, return null as of 6/6/2011 120 ;; Nope, not now, return null as of 6/6/2011 > 121 > 122 (define (check-valid-items class item) > 123 (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class))) > 124 (if s (string-split s) #f)))) > 125 (if valid-values > 126 (if (member item valid-values) > 127 item #f) > 128 item))) 121 129 122 130 123 ;; (pp (item-assoc->item-list itemdat)) 131 ;; (pp (item-assoc->item-list itemdat)) 124 132 125 133 126 134

Added old-runs.scm version [7bcb24f541f2e9d4]

> 1 ;; register a test run with the db > 2 (define (register-run db keys) ;; test-name) > 3 (let* ((keystr (keys->keystr keys)) > 4 (comma (if (> (length keys) 0) "," "")) > 5 (andstr (if (> (length keys) 0) " AND " "")) > 6 (valslots (keys->valslots keys)) ;; ?,?,? ... > 7 (keyvallst (keys->vallist keys)) ;; extracts the values from remainder > 8 (runname (get-with-default ":runname" #f)) > 9 (state (get-with-default ":state" "no")) > 10 (status (get-with-default ":status" "n/a")) > 11 (allvals (append (list runname state status user) keyvallst)) > 12 (qryvals (append (list runname) keyvallst)) > 13 (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname > 14 (debug:print 3 "keys: " keys " allvals: " allvals " keyvallst: " keyvallst) > 15 (debug:print 2 "NOTE: using key " (string-intersperse keyvallst "/") " for t > 16 (if (and runname (null? (filter (lambda (x)(not x)) keyvallst))) ;; there mu > 17 (let ((res #f)) > 18 (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,s > 19 allvals) > 20 (apply sqlite3:for-each-row > 21 (lambda (id) > 22 (set! res id)) > 23 db > 24 (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=? > 25 ;(debug:print 4 "qry: " qry) > 26 qry) > 27 qryvals) > 28 (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" sta > 29 res) > 30 (begin > 31 (debug:print 0 "ERROR: Called without all necessary keys") > 32 #f)))) > 33 > 34 ;; This is original run-tests, this routine is deprecated and we will transition > 35 ;; > 36 (define (run-tests db test-names) > 37 (let* ((keys (db-get-keys db)) > 38 (keyvallst (keys->vallist keys #t)) > 39 (run-id (register-run db keys)) ;; test-name))) > 40 (deferred '()) ;; delay running these since they have a waiton claus > 41 (runconfigf (conc *toppath* "/runconfigs.config")) > 42 (required-tests '())) > 43 > 44 ;; now add non-directly referenced dependencies (i.e. waiton) > 45 ;; could cache all these since they need to be read again ... > 46 ;; FIXME SOMEDAY > 47 (if (not (null? test-names)) > 48 (let loop ((hed (car test-names)) > 49 (tal (cdr test-names))) > 50 (let* ((config (test:get-testconfig hed #f)) > 51 (waitons (string-split (let ((w (config-lookup config "requirem > 52 (if w w ""))))) > 53 (for-each > 54 (lambda (waiton) > 55 (if (and waiton (not (member waiton test-names))) > 56 (begin > 57 (set! required-tests (cons waiton required-tests)) > 58 (set! test-names (append test-names (list waiton)))))) > 59 waitons) > 60 (let ((remtests (delete-duplicates (append waitons tal)))) > 61 (if (not (null? remtests)) > 62 (loop (car remtests)(cdr remtests))))))) > 63 > 64 (if (not (null? required-tests)) > 65 (debug:print 1 "INFO: Adding " required-tests " to the run queue") > 66 (debug:print 1 "INFO: No prerequisites added")) > 67 > 68 ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if > 69 ;; -keepgoing is specified > 70 > 71 (set-megatest-env-vars db run-id) ;; these may be needed by the launching pr > 72 > 73 (if (file-exists? runconfigf) > 74 (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* e > 75 (debug:print 0 "WARNING: You do not have a run config file: " runconfigf > 76 > 77 (if (and (eq? *passnum* 0) > 78 (args:get-arg "-keepgoing")) > 79 (begin > 80 ;; have to delete test records where NOT_STARTED since they can cause > 81 ;; get stuck due to becoming inaccessible from a failed test. I.e. if > 82 ;; on test A but test B reached the point on being registered as NOT_S > 83 ;; A failed for some reason then on re-run using -keepgoing the run ca > 84 (db:delete-tests-in-state db run-id "NOT_STARTED") > 85 (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED > 86 (set! *passnum* (+ *passnum* 1)) > 87 (let loop ((numtimes 0)) > 88 (for-each > 89 (lambda (test-name) > 90 (if (runs:can-run-more-tests db) > 91 (run-one-test db run-id test-name keyvallst) > 92 ;; add some delay > 93 ;(sleep 2) > 94 )) > 95 (tests:sort-by-priority-and-waiton test-names)) > 96 ;; (run-waiting-tests db) > 97 (if (args:get-arg "-keepgoing") > 98 (let ((estrem (db:estimated-tests-remaining db run-id))) > 99 (if (and (> estrem 0) > 100 (eq? *globalexitstatus* 0)) > 101 (begin > 102 (debug:print 1 "Keep going, estimated " estrem " tests remaini > 103 (thread-sleep! 3) > 104 (run-waiting-tests db) > 105 (loop (+ numtimes 1))))))))) > 106 > 107 ;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc > 108 (define (run-one-test db run-id test-name keyvallst) > 109 (debug:print 1 "Launching test " test-name) > 110 ;; All these vars might be referenced by the testconfig file reader > 111 (setenv "MT_TEST_NAME" test-name) ;; > 112 (setenv "MT_RUNNAME" (args:get-arg ":runname")) > 113 > 114 ;; (set-megatest-env-vars db run-id) ;; these may be needed by the launching p > 115 > 116 (change-directory *toppath*) > 117 (let* ((test-path (conc *toppath* "/tests/" test-name)) ;; could use test:g > 118 (test-configf (conc test-path "/testconfig")) > 119 (testexists (and (file-exists? test-configf)(file-read-access? test-c > 120 (test-conf (if testexists (read-config test-configf #f #t) (make-has > 121 (waiton (let ((w (config-lookup test-conf "requirements" "waiton" > 122 (if (string? w)(string-split w)'()))) > 123 (tags (let ((t (config-lookup test-conf "setup" "tags"))) > 124 ;; we want our tags to be separated by commas and fully > 125 ;; so that queries with "like" can tie to the commas at > 126 ;; while also allowing the end user to freely use space > 127 (if (string? t)(string-substitute (regexp "[,\\s]+") ", > 128 '())))) > 129 (if (not testexists) > 130 (begin > 131 (debug:print 0 "ERROR: Can't find config file " test-configf) > 132 (exit 2)) > 133 ;; put top vars into convenient variables and open the db > 134 (let* (;; db is always at *toppath*/db/megatest.db > 135 (items (hash-table-ref/default test-conf "items" '())) > 136 (itemstable (hash-table-ref/default test-conf "itemstable" '())) > 137 (allitems (if (or (not (null? items))(not (null? itemstable))) > 138 (append (item-assoc->item-list items) > 139 (item-table->item-list itemstable)) > 140 '(())))) ;; a list with one null list is a test > 141 ;; (runconfigf (conc *toppath* "/runconfigs.config"))) > 142 (debug:print 1 "items: ") > 143 (if (>= *verbosity* 1)(pp allitems)) > 144 (if (>= *verbosity* 5) > 145 (begin > 146 (print "items: ")(pp (item-assoc->item-list items)) > 147 (print "itestable: ")(pp (item-table->item-list itemstable)))) > 148 (if (args:get-arg "-m") > 149 (db:set-comment-for-run db run-id (args:get-arg "-m"))) > 150 > 151 ;; Here is where the test_meta table is best updated > 152 (runs:update-test_meta db test-name test-conf) > 153 > 154 ;; braindead work-around for poorly specified allitems list BUG!!! FIX > 155 (if (null? allitems)(set! allitems '(()))) > 156 (let loop ((itemdat (car allitems)) > 157 (tal (cdr allitems))) > 158 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") > 159 ;; Handle lists of items > 160 (let* ((item-path (item-list->path itemdat)) ;; (string-interspe > 161 (new-test-path (string-intersperse (cons test-path (map cadr > 162 (new-test-name (if (equal? item-path "") test-name (conc test > 163 (testdat #f) > 164 (num-running (db:get-count-tests-running db)) > 165 (max-concurrent-jobs (config-lookup *configdat* "setup" "max_ > 166 (parent-test (and (not (null? items))(equal? item-path ""))) > 167 (single-test (and (null? items) (equal? item-path ""))) > 168 (item-test (not (equal? item-path ""))) > 169 (item-patt (args:get-arg "-itempatt")) > 170 (patt-match (if item-patt > 171 (string-search (glob->regexp > 172 (string-translate item-patt " > 173 item-path) > 174 #t))) > 175 (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num- > 176 (if (and patt-match (runs:can-run-more-tests db)) > 177 (begin > 178 (let loop2 ((ts (db:get-test-info db run-id test-name item-p > 179 (ct 0)) > 180 (if (and (not ts) > 181 (< ct 10)) > 182 (begin > 183 (register-test db run-id test-name item-path) > 184 (db:test-set-comment db run-id test-name item-path " > 185 (loop2 (db:get-test-info db run-id test-name item-pa > 186 (+ ct 1))) > 187 (if ts > 188 (set! testdat ts) > 189 (begin > 190 (debug:print 0 "WARNING: Couldn't register test > 191 (if (not (null? tal)) > 192 (loop (car tal)(cdr tal))))))) > 193 (change-directory test-path) > 194 ;; this block is here only to inform the user early on > 195 > 196 ;; NB// Moving the setting of runconfig.config vars to *befo > 197 ;; the calling of each test. > 198 ;; (if (file-exists? runconfigf) > 199 ;; (setup-env-defaults db runconfigf run-id *already-see > 200 ;; (debug:print 0 "WARNING: You do not have a run config > 201 (debug:print 4 "run-id: " run-id " test-name: " test-name " > 202 (case (if (args:get-arg "-force") > 203 'NOT_STARTED > 204 (if testdat > 205 (string->symbol (test:get-state testdat)) > 206 'failed-to-insert)) > 207 ((failed-to-insert) > 208 (debug:print 0 "ERROR: Failed to insert the record into t > 209 ((NOT_STARTED COMPLETED) > 210 (debug:print 6 "Got here, " (test:get-state testdat)) > 211 (let ((runflag #f)) > 212 (cond > 213 ;; i.e. this is the parent test to a suite of items, n > 214 (parent-test > 215 (set! runflag #f)) > 216 ;; -force, run no matter what > 217 ((args:get-arg "-force")(set! runflag #t)) > 218 ;; NOT_STARTED, run no matter what > 219 ((equal? (test:get-state testdat) "NOT_STARTED")(set! > 220 ;; not -rerun and PASS, WARN or CHECK, do no run > 221 ((and (or (not (args:get-arg "-rerun")) > 222 (args:get-arg "-keepgoing")) > 223 (member (test:get-status testdat) '("PASS" "WARN > 224 (set! runflag #f)) > 225 ;; -rerun and status is one of the specifed, run it > 226 ((and (args:get-arg "-rerun") > 227 (let ((rerunlst (string-split (args:get-arg "-re > 228 (member (test:get-status testdat) rerunlst))) > 229 (set! runflag #t)) > 230 ;; -keepgoing, do not rerun FAIL > 231 ((and (args:get-arg "-keepgoing") > 232 (member (test:get-status testdat) '("FAIL"))) > 233 (set! runflag #f)) > 234 ((and (not (args:get-arg "-rerun")) > 235 (member (test:get-status testdat) '("FAIL" "n/a" > 236 (set! runflag #t)) > 237 (else (set! runflag #f))) > 238 (debug:print 6 "RUNNING => runflag: " runflag " STATE: > 239 (if (not runflag) > 240 (if (not parent-test) > 241 (debug:print 1 "NOTE: Not starting test " new-t > 242 (let* ((get-prereqs-cmd (lambda () > 243 (db-get-prereqs-not-met d > 244 (launch-cmd (lambda () > 245 (launch-test db run-id (a > 246 (testrundat (list get-prereqs-cmd launc > 247 (if (or (args:get-arg "-force") > 248 (let ((preqs-not-yet-met ((car testrundat > 249 (debug:print 2 "Preqrequesites for " te > 250 (null? preqs-not-yet-met))) ;; are ther > 251 (if (not ((cadr testrundat))) ;; this is the > 252 (begin > 253 (print "ERROR: Failed to launch the tes > 254 (set! *globalexitstatus* 1) ;; > 255 (process-signal (current-process-id) si > 256 ;(exit 1) > 257 )) > 258 (if (not (args:get-arg "-keepgoing")) > 259 (hash-table-set! *waiting-queue* new-test > 260 ((KILLED) > 261 (debug:print 1 "NOTE: " new-test-name " is already runnin > 262 ((LAUNCHED REMOTEHOSTSTART RUNNING) > 263 (if (> (- (current-seconds)(+ (db:test-get-event_time tes > 264 (db:test-get-run_duration t > 265 100) ;; i.e. no update for more than 100 seconds > 266 (begin > 267 (debug:print 0 "WARNING: Test " test-name " appears > 268 (test-set-status! db run-id test-name "INCOMPLETE" > 269 (debug:print 2 "NOTE: " test-name " is already runnin > 270 (else (debug:print 0 "ERROR: Failed to launch test " > 271 (if (not (null? tal)) > 272 (loop (car tal)(cdr tal))))))))) > 273 > 274 (define (run-waiting-tests db) > 275 (let ((numtries 0) > 276 (last-try-time (current-seconds)) > 277 (times (list 1))) ;; minutes to wait before trying again to > 278 ;; BUG this hack of brute force retrying works quite well for many cases but > 279 ;; what is needed is to check the db for tests that have failed less tha > 280 ;; N times or never been started and kick them off again > 281 (let loop ((waiting-test-names (hash-table-keys *waiting-queue*))) > 282 (cond > 283 ((not (runs:can-run-more-tests db)) > 284 (thread-sleep! 2) > 285 (loop waiting-test-names)) > 286 ((null? waiting-test-names) > 287 (debug:print 1 "All tests launched")) > 288 (else > 289 (set! numtries (+ numtries 1)) > 290 (for-each (lambda (testname) > 291 (if (runs:can-run-more-tests db) > 292 (let* ((testdat (hash-table-ref *waiting-queue* testname > 293 (prereqs ((car testdat))) > 294 (ldb (if db db (open-db)))) > 295 (debug:print 2 "prereqs remaining: " prereqs) > 296 (if (null? prereqs) > 297 (begin > 298 (debug:print 2 "Prerequisites met, launching " t > 299 ((cadr testdat)) > 300 (hash-table-delete! *waiting-queue* testname))) > 301 (if (not db) > 302 (sqlite3:finalize! ldb))))) > 303 waiting-test-names) > 304 ;; (sleep 10) ;; no point in rushing things at this stage? > 305 (loop (hash-table-keys *waiting-queue*)))))))

Modified runs.scm from [d434521016458489] to [5d46e1bbed85c030].

14 (import (prefix sqlite3 sqlite3:)) 14 (import (prefix sqlite3 sqlite3:)) 15 15 16 (declare (unit runs)) 16 (declare (unit runs)) 17 (declare (uses db)) 17 (declare (uses db)) 18 (declare (uses common)) 18 (declare (uses common)) 19 (declare (uses items)) 19 (declare (uses items)) 20 (declare (uses runconfig)) 20 (declare (uses runconfig)) > 21 (declare (uses tests)) 21 22 22 (include "common_records.scm") 23 (include "common_records.scm") 23 (include "key_records.scm") 24 (include "key_records.scm") 24 (include "db_records.scm") 25 (include "db_records.scm") 25 (include "run_records.scm") 26 (include "run_records.scm") 26 27 27 ;; register a test run with the db | 28 ;; stuff to be deprecated then removed 28 (define (register-run db keys) ;; test-name) | 29 (include "old-runs.scm") 29 (let* ((keystr (keys->keystr keys)) < 30 (comma (if (> (length keys) 0) "," "")) < 31 (andstr (if (> (length keys) 0) " AND " "")) < 32 (valslots (keys->valslots keys)) ;; ?,?,? ... < 33 (keyvallst (keys->vallist keys)) ;; extracts the values from remainder < 34 (runname (get-with-default ":runname" #f)) < 35 (state (get-with-default ":state" "no")) < 36 (status (get-with-default ":status" "n/a")) < 37 (allvals (append (list runname state status user) keyvallst)) < 38 (qryvals (append (list runname) keyvallst)) < 39 (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname < 40 (debug:print 3 "keys: " keys " allvals: " allvals " keyvallst: " keyvallst) < 41 (debug:print 2 "NOTE: using key " (string-intersperse keyvallst "/") " for t < 42 (if (and runname (null? (filter (lambda (x)(not x)) keyvallst))) ;; there mu < 43 (let ((res #f)) < 44 (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,s < 45 allvals) < 46 (apply sqlite3:for-each-row < 47 (lambda (id) < 48 (set! res id)) < 49 db < 50 (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=? < 51 ;(debug:print 4 "qry: " qry) < 52 qry) < 53 qryvals) < 54 (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" sta < 55 res) < 56 (begin < 57 (debug:print 0 "ERROR: Called without all necessary keys") < 58 #f)))) < > 30 59 31 60 ;; runs:get-runs-by-patt 32 ;; runs:get-runs-by-patt 61 ;; get runs by list of criteria 33 ;; get runs by list of criteria 62 ;; register a test run with the db 34 ;; register a test run with the db 63 ;; 35 ;; 64 ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) 36 ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) 65 ;; to extract info from the structure returned 37 ;; to extract info from the structure returned ................................................................................................................................................................................ 85 (lambda (a . r) 57 (lambda (a . r) 86 (set! res (cons (list->vector (cons a r)) res))) 58 (set! res (cons (list->vector (cons a r)) res))) 87 db 59 db 88 (conc "SELECT " keystr " FROM runs WHERE runname like ? " key-patt ";") 60 (conc "SELECT " keystr " FROM runs WHERE runname like ? " key-patt ";") 89 runnamepatt) 61 runnamepatt) 90 (vector header res))) 62 (vector header res))) 91 63 92 (define (register-test db run-id test-name item-path) < 93 (let ((item-paths (if (equal? item-path "") < 94 (list item-path) < 95 (list item-path "")))) < 96 (for-each < 97 (lambda (pth) < 98 (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_t < 99 run-id < 100 test-name < 101 pth < 102 ;; (conc "," (string-intersperse tags ",") ",") < 103 )) < 104 item-paths ))) < 105 < 106 ;; get the previous record for when this test was run where all keys match but r < 107 ;; returns #f if no such test found, returns a single test record if found < 108 (define (test:get-previous-test-run-record db run-id test-name item-path) < 109 (let* ((keys (db:get-keys db)) < 110 (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ", < 111 (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=? < 112 (keyvals #f)) < 113 ;; first look up the key values from the run selected by run-id < 114 (sqlite3:for-each-row < 115 (lambda (a . b) < 116 (set! keyvals (cons a b))) < 117 db < 118 (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") r < 119 (if (not keyvals) < 120 #f < 121 (let ((prev-run-ids '())) < 122 (apply sqlite3:for-each-row < 123 (lambda (id) < 124 (set! prev-run-ids (cons id prev-run-ids))) < 125 db < 126 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (app < 127 ;; for each run starting with the most recent look to see if there is < 128 ;; if found then return that matching test record < 129 (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " key < 130 (if (null? prev-run-ids) #f < 131 (let loop ((hed (car prev-run-ids)) < 132 (tal (cdr prev-run-ids))) < 133 (let ((results (db-get-tests-for-run db hed test-name item-path < 134 (debug:print 4 "Got tests for run-id " run-id ", test-name " t < 135 (if (and (null? results) < 136 (not (null? tal))) < 137 (loop (car tal)(cdr tal)) < 138 (if (null? results) #f < 139 (car results)))))))))) < 140 < 141 ;; get the previous records for when these tests were run where all keys match b < 142 ;; NB// Merge this with test:get-previous-test-run-records? This one looks for a < 143 ;; can use wildcards. < 144 (define (test:get-matching-previous-test-run-records db run-id test-name item-pa < 145 (let* ((keys (db:get-keys db)) < 146 (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ", < 147 (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=? < 148 (keyvals #f) < 149 (tests-hash (make-hash-table))) < 150 ;; first look up the key values from the run selected by run-id < 151 (sqlite3:for-each-row < 152 (lambda (a . b) < 153 (set! keyvals (cons a b))) < 154 db < 155 (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") r < 156 (if (not keyvals) < 157 '() < 158 (let ((prev-run-ids '())) < 159 (apply sqlite3:for-each-row < 160 (lambda (id) < 161 (set! prev-run-ids (cons id prev-run-ids))) < 162 db < 163 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (app < 164 ;; collect all matching tests for the runs then < 165 ;; extract the most recent test and return that. < 166 (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " key < 167 ", previous run ids found: " prev-run-ids) < 168 (if (null? prev-run-ids) '() ;; no previous runs? return null < 169 (let loop ((hed (car prev-run-ids)) < 170 (tal (cdr prev-run-ids))) < 171 (let ((results (db-get-tests-for-run db hed test-name item-path < 172 (debug:print 4 "Got tests for run-id " run-id ", test-name " t < 173 ", item-path " item-path " results: " (interspers < 174 ;; Keep only the youngest of any test/item combination < 175 (for-each < 176 (lambda (testdat) < 177 (let* ((full-testname (conc (db:test-get-testname testdat) < 178 (stored-test (hash-table-ref/default tests-hash fu < 179 (if (or (not stored-test) < 180 (and stored-test < 181 (> (db:test-get-event_time testdat)(db:test- < 182 ;; this test is younger, store it in the hash < 183 (hash-table-set! tests-hash full-testname testdat)))) < 184 results) < 185 (if (null? tal) < 186 (map cdr (hash-table->alist tests-hash)) ;; return a list < 187 (loop (car tal)(cdr tal)))))))))) < 188 < 189 (define (test-set-status! db run-id test-name state status itemdat-or-path comme < 190 (let* ((real-status status) < 191 (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list-> < 192 (testdat (db:get-test-info db run-id test-name item-path)) < 193 (test-id (if testdat (db:test-get-id testdat) #f)) < 194 (otherdat (if dat dat (make-hash-table))) < 195 ;; before proceeding we must find out if the previous test (where all k < 196 ;; was WAIVED if this test is FAIL < 197 (waived (if (equal? status "FAIL") < 198 (let ((prev-test (test:get-previous-test-run-record db ru < 199 (if prev-test ;; true if we found a previous test in th < 200 (let ((prev-status (db:test-get-status prev-test) < 201 (prev-state (db:test-get-state prev-test) < 202 (prev-comment (db:test-get-comment prev-test) < 203 (debug:print 4 "prev-status " prev-status ", prev < 204 (if (and (equal? prev-state "COMPLETED") < 205 (equal? prev-status "WAIVED")) < 206 prev-comment ;; waived is either the comment < 207 #f)) < 208 #f)) < 209 #f))) < 210 (if waived (set! real-status "WAIVED")) < 211 (debug:print 4 "real-status " real-status ", waived " waived ", status " sta < 212 < 213 ;; update the primary record IF state AND status are defined < 214 (if (and state status) < 215 (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strfti < 216 state real-status run-id test-name item-path)) < 217 < 218 ;; if status is "AUTO" then call rollup < 219 (if (and test-id state status (equal? status "AUTO")) < 220 (db:test-data-rollup db test-id)) < 221 < 222 ;; add metadata (need to do this way to avoid SQL injection issues) < 223 < 224 ;; :first_err < 225 ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) < 226 ;; (if val < 227 ;; (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AN < 228 ;; < 229 ;; ;; :first_warn < 230 ;; (let ((val (hash-table-ref/default otherdat ":first_warn" #f))) < 231 ;; (if val < 232 ;; (sqlite3:execute db "UPDATE tests SET first_warn=? WHERE run_id=? A < 233 < 234 (let ((category (hash-table-ref/default otherdat ":category" "")) < 235 (variable (hash-table-ref/default otherdat ":variable" "")) < 236 (value (hash-table-ref/default otherdat ":value" #f)) < 237 (expected (hash-table-ref/default otherdat ":expected" #f)) < 238 (tol (hash-table-ref/default otherdat ":tol" #f)) < 239 (units (hash-table-ref/default otherdat ":units" "")) < 240 (dcomment (hash-table-ref/default otherdat ":comment" ""))) < 241 (debug:print 4 < 242 "category: " category ", variable: " variable ", value: " val < 243 ", expected: " expected ", tol: " tol ", units: " units) < 244 (if (and value expected tol) ;; all three required < 245 (db:csv->test-data db test-id < 246 (conc category "," < 247 variable "," < 248 value "," < 249 expected "," < 250 tol "," < 251 units "," < 252 dcomment ",")))) < 253 < 254 ;; need to update the top test record if PASS or FAIL and this is a subtest < 255 (if (and (not (equal? item-path "")) < 256 (or (equal? status "PASS") < 257 (equal? status "WARN") < 258 (equal? status "FAIL") < 259 (equal? status "WAIVED") < 260 (equal? status "RUNNING"))) < 261 (begin < 262 (sqlite3:execute < 263 db < 264 "UPDATE tests < 265 SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND test < 266 pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND test < 267 WHERE run_id=? AND testname=? AND item_path='';" < 268 run-id test-name run-id test-name run-id test-name) < 269 (if (equal? status "RUNNING") ;; running takes priority over all other < 270 (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND t < 271 (sqlite3:execute < 272 db < 273 "UPDATE tests < 274 SET state=CASE WHEN (SELECT count(id) FROM tests WHERE ru < 275 'RUNNING' < 276 ELSE 'COMPLETED' END, < 277 status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_ < 278 WHERE run_id=? AND testname=? AND item_path='';" < 279 run-id test-name run-id test-name)))) < 280 (if (or (and (string? comment) < 281 (string-match (regexp "\\S+") comment)) < 282 waived) < 283 (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testn < 284 (if waived waived comment) run-id test-name item-path)) < 285 )) < 286 < 287 (define (test-set-log! db run-id test-name itemdat logf) < 288 (let ((item-path (item-list->path itemdat))) < 289 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testna < 290 logf run-id test-name item-path))) < 291 < 292 (define (test-set-toplog! db run-id test-name logf) < 293 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname < 294 logf run-id test-name)) < 295 < 296 (define (tests:summarize-items db run-id test-name force) < 297 ;; if not force then only update the record if one of these is true: < 298 ;; 1. logf is "log/final.log < 299 ;; 2. logf is same as outputfilename < 300 (let ((outputfilename (conc "megatest-rollup-" test-name ".html")) < 301 (orig-dir (current-directory)) < 302 (logf #f)) < 303 (sqlite3:for-each-row < 304 (lambda (path final_logf) < 305 (set! logf final_logf) < 306 (if (directory? path) < 307 (begin < 308 (print "Found path: " path) < 309 (change-directory path)) < 310 ;; (set! outputfilename (conc path "/" outputfilename))) < 311 (print "No such path: " path))) < 312 db < 313 "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item < 314 run-id test-name) < 315 (print "summarize-items with logf " logf) < 316 (if (or (equal? logf "logs/final.log") < 317 (equal? logf outputfilename) < 318 force) < 319 (begin < 320 (if (obtain-dot-lock outputfilename 1 20 30) ;; retry every second for < 321 (print "Obtained lock for " outputfilename) < 322 (print "Failed to obtain lock for " outputfilename)) < 323 (let ((oup (open-output-file outputfilename)) < 324 (counts (make-hash-table)) < 325 (statecounts (make-hash-table)) < 326 (outtxt "") < 327 (tot 0)) < 328 (with-output-to-port < 329 oup < 330 (lambda () < 331 (set! outtxt (conc outtxt "<html><title>Summary: " test-name < 332 "</title><body><h2>Summary for " test-name "< < 333 (sqlite3:for-each-row < 334 (lambda (id itempath state status run_duration logf comment) < 335 (hash-table-set! counts status (+ 1 (hash-table-ref/default c < 336 (hash-table-set! statecounts state (+ 1 (hash-table-ref/defau < 337 (set! outtxt (conc outtxt "<tr>" < 338 "<td><a href=\"" itempath "/" logf "\"> " < 339 "<td>" state "</td>" < 340 "<td><font color=" (common:get-color-from- < 341 ">" status "</font></td>" < 342 "<td>" (if (equal? comment "") < 343 "&nbsp;" < 344 comment) "</td>" < 345 "</tr>"))) < 346 db < 347 "SELECT id,item_path,state,status,run_duration,final_logf,comme < 348 run-id test-name) < 349 < 350 (print "<table><tr><td valign=\"top\">") < 351 ;; Print out stats for status < 352 (set! tot 0) < 353 (print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\" < 354 (for-each (lambda (state) < 355 (set! tot (+ tot (hash-table-ref statecounts state)) < 356 (print "<tr><td>" state "</td><td>" (hash-table-ref < 357 (hash-table-keys statecounts)) < 358 (print "<tr><td>Total</td><td>" tot "</td></tr></table>") < 359 (print "</td><td valign=\"top\">") < 360 ;; Print out stats for state < 361 (set! tot 0) < 362 (print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\" < 363 (for-each (lambda (status) < 364 (set! tot (+ tot (hash-table-ref counts status))) < 365 (print "<tr><td><font color=\"" (common:get-color-fr < 366 "</font></td><td>" (hash-table-ref counts sta < 367 (hash-table-keys counts)) < 368 (print "<tr><td>Total</td><td>" tot "</td></tr></table>") < 369 (print "</td></td></tr></table>") < 370 < 371 (print "<table cellspacing=\"0\" border=\"1\">" < 372 "<tr><td>Item</td><td>State</td><td>Status</td><td>Commen < 373 outtxt "</table></body></html>") < 374 (release-dot-lock outputfilename))) < 375 (close-output-port oup) < 376 (change-directory orig-dir) < 377 (test-set-toplog! db run-id test-name outputfilename) < 378 ))))) < 379 < 380 ;; ;; TODO: Converge this with db:get-test-info 64 ;; ;; TODO: Converge this with db:get-test-info 381 ;; (define (runs:get-test-info db run-id test-name item-path) 65 ;; (define (runs:get-test-info db run-id test-name item-path) 382 ;; (let ((res #f)) ;; (vector #f #f #f #f #f #f))) 66 ;; (let ((res #f)) ;; (vector #f #f #f #f #f #f))) 383 ;; (sqlite3:for-each-row 67 ;; (sqlite3:for-each-row 384 ;; (lambda (id run-id test-name state status) 68 ;; (lambda (id run-id test-name state status) 385 ;; (set! res (vector id run-id test-name state status item-path))) 69 ;; (set! res (vector id run-id test-name state status item-path))) 386 ;; db "SELECT id,run_id,testname,state,status FROM tests WHERE run_id=? AND 70 ;; db "SELECT id,run_id,testname,state,status FROM tests WHERE run_id=? AND ................................................................................................................................................................................ 388 ;; res)) 72 ;; res)) 389 73 390 (define (runs:test-get-full-path test) 74 (define (runs:test-get-full-path test) 391 (let* ((testname (db:test-get-testname test)) 75 (let* ((testname (db:test-get-testname test)) 392 (itempath (db:test-get-item-path test))) 76 (itempath (db:test-get-item-path test))) 393 (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) 77 (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) 394 78 395 (define (check-valid-items class item) < 396 (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class))) < 397 (if s (string-split s) #f)))) < 398 (if valid-values < 399 (if (member item valid-values) < 400 item #f) < 401 item))) < 402 < 403 (define (teststep-set-status! db run-id test-name teststep-name state-in status- < 404 (debug:print 4 "run-id: " run-id " test-name: " test-name) < 405 (let* ((state (check-valid-items "state" state-in)) < 406 (status (check-valid-items "status" status-in)) < 407 (item-path (item-list->path itemdat)) < 408 (testdat (db:get-test-info db run-id test-name item-path))) < 409 (debug:print 5 "testdat: " testdat) < 410 (if (and testdat ;; if the section exists then force specification BUG, I do < 411 (or (not state)(not status))) < 412 (debug:print 0 "WARNING: Invalid " (if status "status" "state") < 413 " value \"" (if status state-in status-in) "\", update your valid < 414 (if testdat < 415 (let ((test-id (test:get-id testdat))) < 416 ;; FIXME - this should not update the logfile unless it is specified. < 417 (sqlite3:execute db < 418 "INSERT OR REPLACE into test_steps (test_id,stepname,sta < 419 test-id teststep-name state-in status-in (if comment com < 420 (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> < 421 < 422 (define (test-get-kill-request db run-id test-name itemdat) < 423 (let* ((item-path (item-list->path itemdat)) < 424 (testdat (db:get-test-info db run-id test-name item-path))) < 425 (equal? (test:get-state testdat) "KILLREQ"))) < 426 < 427 (define (test-set-meta-info db run-id testname itemdat) < 428 (let ((item-path (item-list->path itemdat)) < 429 (cpuload (get-cpu-load)) < 430 (hostname (get-host-name)) < 431 (diskfree (get-df (current-directory))) < 432 (uname (get-uname "-srvpio")) < 433 (runpath (current-directory))) < 434 (sqlite3:execute db "UPDATE tests SET host=?,cpuload=?,diskfree=?,uname=?,ru < 435 hostname < 436 cpuload < 437 diskfree < 438 uname < 439 runpath < 440 run-id < 441 testname < 442 item-path))) < 443 < 444 (define (test-update-meta-info db run-id testname itemdat minutes cpuload diskfr < 445 (let ((item-path (item-list->path itemdat))) < 446 (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (se < 447 ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) < 448 ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) < 449 ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) < 450 (sqlite3:execute < 451 db < 452 "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE < 453 cpuload < 454 diskfree < 455 minutes < 456 run-id < 457 testname < 458 item-path))) < 459 79 460 (define (set-megatest-env-vars db run-id) 80 (define (set-megatest-env-vars db run-id) 461 (let ((keys (db-get-keys db))) 81 (let ((keys (db-get-keys db))) 462 (for-each (lambda (key) 82 (for-each (lambda (key) 463 (sqlite3:for-each-row 83 (sqlite3:for-each-row 464 (lambda (val) 84 (lambda (val) 465 (debug:print 2 "setenv " (key:get-fieldname key) " " val) 85 (debug:print 2 "setenv " (key:get-fieldname key) " " val) ................................................................................................................................................................................ 471 91 472 (define (set-item-env-vars itemdat) 92 (define (set-item-env-vars itemdat) 473 (for-each (lambda (item) 93 (for-each (lambda (item) 474 (debug:print 2 "setenv " (car item) " " (cadr item)) 94 (debug:print 2 "setenv " (car item) " " (cadr item)) 475 (setenv (car item) (cadr item))) 95 (setenv (car item) (cadr item))) 476 itemdat)) 96 itemdat)) 477 97 478 (define (get-all-legal-tests) < 479 (let* ((tests (glob (conc *toppath* "/tests/*"))) < 480 (res '())) < 481 (debug:print 4 "INFO: Looking at tests " (string-intersperse tests ",")) < 482 (for-each (lambda (testpath) < 483 (if (file-exists? (conc testpath "/testconfig")) < 484 (set! res (cons (last (string-split testpath "/")) res)))) < 485 tests) < 486 res)) < 487 < 488 (define (runs:can-run-more-tests db) 98 (define (runs:can-run-more-tests db) 489 (let ((num-running (db:get-count-tests-running db)) 99 (let ((num-running (db:get-count-tests-running db)) 490 (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_ 100 (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_ 491 (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " 101 (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " 492 (if (not (eq? 0 *globalexitstatus*)) 102 (if (not (eq? 0 *globalexitstatus*)) 493 #f 103 #f 494 (if (or (not max-concurrent-jobs) 104 (if (or (not max-concurrent-jobs) ................................................................................................................................................................................ 497 (not (>= num-running (string->number max-concurrent-jobs))) 107 (not (>= num-running (string->number max-concurrent-jobs))) 498 #t 108 #t 499 (begin 109 (begin 500 (debug:print 0 "WARNING: Max running jobs exceeded, current number 110 (debug:print 0 "WARNING: Max running jobs exceeded, current number 501 ", max_concurrent_jobs: " max-concurrent-jobs) 111 ", max_concurrent_jobs: " max-concurrent-jobs) 502 #f))))) 112 #f))))) 503 113 504 (define (test:get-testconfig test-name system-allowed) < 505 (let* ((test-path (conc *toppath* "/tests/" test-name)) < 506 (test-configf (conc test-path "/testconfig")) < 507 (testexists (and (file-exists? test-configf)(file-read-access? test-c < 508 (if testexists < 509 (read-config test-configf #f system-allowed environ-patt: (if system-all < 510 "pre-launc < 511 #f)) < 512 #f))) < 513 < 514 ;; sort tests by priority and waiton < 515 ;; Move test specific stuff to a test unit FIXME one of these days < 516 (define (tests:sort-by-priority-and-waiton test-names) < 517 (let ((testdetails (make-hash-table)) < 518 (mungepriority (lambda (priority) < 519 (if priority < 520 (let ((tmp (any->number priority))) < 521 (if tmp tmp (begin (debug:print 0 "ERROR: bad pri < 522 0)))) < 523 (for-each (lambda (test-name) < 524 (let ((test-config (test:get-testconfig test-name #f))) < 525 (if test-config (hash-table-set! testdetails test-name test-co < 526 test-names) < 527 (sort < 528 (hash-table-keys testdetails) ;; avoid dealing with deleted tests, look at < 529 (lambda (a b) < 530 (let* ((tconf-a (hash-table-ref testdetails a)) < 531 (tconf-b (hash-table-ref testdetails b)) < 532 (a-waiton (config-lookup tconf-a "requirements" "waiton")) < 533 (b-waiton (config-lookup tconf-b "requirements" "waiton")) < 534 (a-priority (mungepriority (config-lookup tconf-a "requirements" " < 535 (b-priority (mungepriority (config-lookup tconf-b "requirements" " < 536 (if (and a-waiton (equal? a-waiton b)) < 537 #f ;; cannot have a which is waiting on b happening before b < 538 (if (and b-waiton (equal? b-waiton a)) < 539 #t ;; this is the correct order, b is waiting on a and b is bef < 540 (if (> a-priority b-priority) < 541 #t ;; if a is a higher priority than b then we are good to < 542 #f)))))))) < 543 < 544 ;; This is original run-tests, this routine is deprecated and we will transition < 545 ;; < 546 (define (run-tests db test-names) < 547 (let* ((keys (db-get-keys db)) < 548 (keyvallst (keys->vallist keys #t)) < 549 (run-id (register-run db keys)) ;; test-name))) < 550 (deferred '()) ;; delay running these since they have a waiton claus < 551 (runconfigf (conc *toppath* "/runconfigs.config")) < 552 (required-tests '())) < 553 < 554 ;; now add non-directly referenced dependencies (i.e. waiton) < 555 ;; could cache all these since they need to be read again ... < 556 ;; FIXME SOMEDAY < 557 (if (not (null? test-names)) < 558 (let loop ((hed (car test-names)) < 559 (tal (cdr test-names))) < 560 (let* ((config (test:get-testconfig hed #f)) < 561 (waitons (string-split (let ((w (config-lookup config "requirem < 562 (if w w ""))))) < 563 (for-each < 564 (lambda (waiton) < 565 (if (and waiton (not (member waiton test-names))) < 566 (begin < 567 (set! required-tests (cons waiton required-tests)) < 568 (set! test-names (append test-names (list waiton)))))) < 569 waitons) < 570 (let ((remtests (delete-duplicates (append waitons tal)))) < 571 (if (not (null? remtests)) < 572 (loop (car remtests)(cdr remtests))))))) < 573 < 574 (if (not (null? required-tests)) < 575 (debug:print 1 "INFO: Adding " required-tests " to the run queue") < 576 (debug:print 1 "INFO: No prerequisites added")) < 577 < 578 ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if < 579 ;; -keepgoing is specified < 580 < 581 (set-megatest-env-vars db run-id) ;; these may be needed by the launching pr < 582 < 583 (if (file-exists? runconfigf) < 584 (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* e < 585 (debug:print 0 "WARNING: You do not have a run config file: " runconfigf < 586 < 587 (if (and (eq? *passnum* 0) < 588 (args:get-arg "-keepgoing")) < 589 (begin < 590 ;; have to delete test records where NOT_STARTED since they can cause < 591 ;; get stuck due to becoming inaccessible from a failed test. I.e. if < 592 ;; on test A but test B reached the point on being registered as NOT_S < 593 ;; A failed for some reason then on re-run using -keepgoing the run ca < 594 (db:delete-tests-in-state db run-id "NOT_STARTED") < 595 (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED < 596 (set! *passnum* (+ *passnum* 1)) < 597 (let loop ((numtimes 0)) < 598 (for-each < 599 (lambda (test-name) < 600 (if (runs:can-run-more-tests db) < 601 (run-one-test db run-id test-name keyvallst) < 602 ;; add some delay < 603 ;(sleep 2) < 604 )) < 605 (tests:sort-by-priority-and-waiton test-names)) < 606 ;; (run-waiting-tests db) < 607 (if (args:get-arg "-keepgoing") < 608 (let ((estrem (db:estimated-tests-remaining db run-id))) < 609 (if (and (> estrem 0) < 610 (eq? *globalexitstatus* 0)) < 611 (begin < 612 (debug:print 1 "Keep going, estimated " estrem " tests remaini < 613 (thread-sleep! 3) < 614 (run-waiting-tests db) < 615 (loop (+ numtimes 1))))))))) < 616 < 617 ;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc < 618 (define (run-one-test db run-id test-name keyvallst) < 619 (debug:print 1 "Launching test " test-name) < 620 ;; All these vars might be referenced by the testconfig file reader < 621 (setenv "MT_TEST_NAME" test-name) ;; < 622 (setenv "MT_RUNNAME" (args:get-arg ":runname")) < 623 < 624 ;; (set-megatest-env-vars db run-id) ;; these may be needed by the launching p < 625 < 626 (change-directory *toppath*) < 627 (let* ((test-path (conc *toppath* "/tests/" test-name)) ;; could use test:g < 628 (test-configf (conc test-path "/testconfig")) < 629 (testexists (and (file-exists? test-configf)(file-read-access? test-c < 630 (test-conf (if testexists (read-config test-configf #f #t) (make-has < 631 (waiton (let ((w (config-lookup test-conf "requirements" "waiton" < 632 (if (string? w)(string-split w)'()))) < 633 (tags (let ((t (config-lookup test-conf "setup" "tags"))) < 634 ;; we want our tags to be separated by commas and fully < 635 ;; so that queries with "like" can tie to the commas at < 636 ;; while also allowing the end user to freely use space < 637 (if (string? t)(string-substitute (regexp "[,\\s]+") ", < 638 '())))) < 639 (if (not testexists) < 640 (begin < 641 (debug:print 0 "ERROR: Can't find config file " test-configf) < 642 (exit 2)) < 643 ;; put top vars into convenient variables and open the db < 644 (let* (;; db is always at *toppath*/db/megatest.db < 645 (items (hash-table-ref/default test-conf "items" '())) < 646 (itemstable (hash-table-ref/default test-conf "itemstable" '())) < 647 (allitems (if (or (not (null? items))(not (null? itemstable))) < 648 (append (item-assoc->item-list items) < 649 (item-table->item-list itemstable)) < 650 '(())))) ;; a list with one null list is a test < 651 ;; (runconfigf (conc *toppath* "/runconfigs.config"))) < 652 (debug:print 1 "items: ") < 653 (if (>= *verbosity* 1)(pp allitems)) < 654 (if (>= *verbosity* 5) < 655 (begin < 656 (print "items: ")(pp (item-assoc->item-list items)) < 657 (print "itestable: ")(pp (item-table->item-list itemstable)))) < 658 (if (args:get-arg "-m") < 659 (db:set-comment-for-run db run-id (args:get-arg "-m"))) < 660 < 661 ;; Here is where the test_meta table is best updated < 662 (runs:update-test_meta db test-name test-conf) < 663 < 664 ;; braindead work-around for poorly specified allitems list BUG!!! FIX < 665 (if (null? allitems)(set! allitems '(()))) < 666 (let loop ((itemdat (car allitems)) < 667 (tal (cdr allitems))) < 668 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") < 669 ;; Handle lists of items < 670 (let* ((item-path (item-list->path itemdat)) ;; (string-interspe < 671 (new-test-path (string-intersperse (cons test-path (map cadr < 672 (new-test-name (if (equal? item-path "") test-name (conc test < 673 (testdat #f) < 674 (num-running (db:get-count-tests-running db)) < 675 (max-concurrent-jobs (config-lookup *configdat* "setup" "max_ < 676 (parent-test (and (not (null? items))(equal? item-path ""))) < 677 (single-test (and (null? items) (equal? item-path ""))) < 678 (item-test (not (equal? item-path ""))) < 679 (item-patt (args:get-arg "-itempatt")) < 680 (patt-match (if item-patt < 681 (string-search (glob->regexp < 682 (string-translate item-patt " < 683 item-path) < 684 #t))) < 685 (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num- < 686 (if (and patt-match (runs:can-run-more-tests db)) < 687 (begin < 688 (let loop2 ((ts (db:get-test-info db run-id test-name item-p < 689 (ct 0)) < 690 (if (and (not ts) < 691 (< ct 10)) < 692 (begin < 693 (register-test db run-id test-name item-path) < 694 (db:test-set-comment db run-id test-name item-path " < 695 (loop2 (db:get-test-info db run-id test-name item-pa < 696 (+ ct 1))) < 697 (if ts < 698 (set! testdat ts) < 699 (begin < 700 (debug:print 0 "WARNING: Couldn't register test < 701 (if (not (null? tal)) < 702 (loop (car tal)(cdr tal))))))) < 703 (change-directory test-path) < 704 ;; this block is here only to inform the user early on < 705 < 706 ;; NB// Moving the setting of runconfig.config vars to *befo < 707 ;; the calling of each test. < 708 ;; (if (file-exists? runconfigf) < 709 ;; (setup-env-defaults db runconfigf run-id *already-see < 710 ;; (debug:print 0 "WARNING: You do not have a run config < 711 (debug:print 4 "run-id: " run-id " test-name: " test-name " < 712 (case (if (args:get-arg "-force") < 713 'NOT_STARTED < 714 (if testdat < 715 (string->symbol (test:get-state testdat)) < 716 'failed-to-insert)) < 717 ((failed-to-insert) < 718 (debug:print 0 "ERROR: Failed to insert the record into t < 719 ((NOT_STARTED COMPLETED) < 720 (debug:print 6 "Got here, " (test:get-state testdat)) < 721 (let ((runflag #f)) < 722 (cond < 723 ;; i.e. this is the parent test to a suite of items, n < 724 (parent-test < 725 (set! runflag #f)) < 726 ;; -force, run no matter what < 727 ((args:get-arg "-force")(set! runflag #t)) < 728 ;; NOT_STARTED, run no matter what < 729 ((equal? (test:get-state testdat) "NOT_STARTED")(set! < 730 ;; not -rerun and PASS, WARN or CHECK, do no run < 731 ((and (or (not (args:get-arg "-rerun")) < 732 (args:get-arg "-keepgoing")) < 733 (member (test:get-status testdat) '("PASS" "WARN < 734 (set! runflag #f)) < 735 ;; -rerun and status is one of the specifed, run it < 736 ((and (args:get-arg "-rerun") < 737 (let ((rerunlst (string-split (args:get-arg "-re < 738 (member (test:get-status testdat) rerunlst))) < 739 (set! runflag #t)) < 740 ;; -keepgoing, do not rerun FAIL < 741 ((and (args:get-arg "-keepgoing") < 742 (member (test:get-status testdat) '("FAIL"))) < 743 (set! runflag #f)) < 744 ((and (not (args:get-arg "-rerun")) < 745 (member (test:get-status testdat) '("FAIL" "n/a" < 746 (set! runflag #t)) < 747 (else (set! runflag #f))) < 748 (debug:print 6 "RUNNING => runflag: " runflag " STATE: < 749 (if (not runflag) < 750 (if (not parent-test) < 751 (debug:print 1 "NOTE: Not starting test " new-t < 752 (let* ((get-prereqs-cmd (lambda () < 753 (db-get-prereqs-not-met d < 754 (launch-cmd (lambda () < 755 (launch-test db run-id (a < 756 (testrundat (list get-prereqs-cmd launc < 757 (if (or (args:get-arg "-force") < 758 (let ((preqs-not-yet-met ((car testrundat < 759 (debug:print 2 "Preqrequesites for " te < 760 (null? preqs-not-yet-met))) ;; are ther < 761 (if (not ((cadr testrundat))) ;; this is the < 762 (begin < 763 (print "ERROR: Failed to launch the tes < 764 (set! *globalexitstatus* 1) ;; < 765 (process-signal (current-process-id) si < 766 ;(exit 1) < 767 )) < 768 (if (not (args:get-arg "-keepgoing")) < 769 (hash-table-set! *waiting-queue* new-test < 770 ((KILLED) < 771 (debug:print 1 "NOTE: " new-test-name " is already runnin < 772 ((LAUNCHED REMOTEHOSTSTART RUNNING) < 773 (if (> (- (current-seconds)(+ (db:test-get-event_time tes < 774 (db:test-get-run_duration t < 775 100) ;; i.e. no update for more than 100 seconds < 776 (begin < 777 (debug:print 0 "WARNING: Test " test-name " appears < 778 (test-set-status! db run-id test-name "INCOMPLETE" < 779 (debug:print 2 "NOTE: " test-name " is already runnin < 780 (else (debug:print 0 "ERROR: Failed to launch test " < 781 (if (not (null? tal)) < 782 (loop (car tal)(cdr tal))))))))) < 783 < 784 (define (run-waiting-tests db) < 785 (let ((numtries 0) < 786 (last-try-time (current-seconds)) < 787 (times (list 1))) ;; minutes to wait before trying again to < 788 ;; BUG this hack of brute force retrying works quite well for many cases but < 789 ;; what is needed is to check the db for tests that have failed less tha < 790 ;; N times or never been started and kick them off again < 791 (let loop ((waiting-test-names (hash-table-keys *waiting-queue*))) < 792 (cond < 793 ((not (runs:can-run-more-tests db)) < 794 (thread-sleep! 2) < 795 (loop waiting-test-names)) < 796 ((null? waiting-test-names) < 797 (debug:print 1 "All tests launched")) < 798 (else < 799 (set! numtries (+ numtries 1)) < 800 (for-each (lambda (testname) < 801 (if (runs:can-run-more-tests db) < 802 (let* ((testdat (hash-table-ref *waiting-queue* testname < 803 (prereqs ((car testdat))) < 804 (ldb (if db db (open-db)))) < 805 (debug:print 2 "prereqs remaining: " prereqs) < 806 (if (null? prereqs) < 807 (begin < 808 (debug:print 2 "Prerequisites met, launching " t < 809 ((cadr testdat)) < 810 (hash-table-delete! *waiting-queue* testname))) < 811 (if (not db) < 812 (sqlite3:finalize! ldb))))) < 813 waiting-test-names) < 814 ;; (sleep 10) ;; no point in rushing things at this stage? < 815 (loop (hash-table-keys *waiting-queue*))))))) < 816 114 817 ;;====================================================================== 115 ;;====================================================================== 818 ;; New methodology. These routines will replace the above in time. For 116 ;; New methodology. These routines will replace the above in time. For 819 ;; now the code is duplicated. This stuff is initially used in the monitor 117 ;; now the code is duplicated. This stuff is initially used in the monitor 820 ;; based code. 118 ;; based code. 821 ;;====================================================================== 119 ;;====================================================================== 822 120

Added tests.scm version [f3725b9582a2fc23]

> 1 (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking) > 2 (import (prefix sqlite3 sqlite3:)) > 3 > 4 (declare (unit tests)) > 5 (declare (uses db)) > 6 (declare (uses common)) > 7 (declare (uses items)) > 8 (declare (uses runconfig)) > 9 > 10 (include "common_records.scm") > 11 (include "key_records.scm") > 12 (include "db_records.scm") > 13 (include "run_records.scm") > 14 > 15 > 16 (define (register-test db run-id test-name item-path) > 17 (let ((item-paths (if (equal? item-path "") > 18 (list item-path) > 19 (list item-path "")))) > 20 (for-each > 21 (lambda (pth) > 22 (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_t > 23 run-id > 24 test-name > 25 pth > 26 ;; (conc "," (string-intersperse tags ",") ",") > 27 )) > 28 item-paths ))) > 29 > 30 ;; get the previous record for when this test was run where all keys match but r > 31 ;; returns #f if no such test found, returns a single test record if found > 32 (define (test:get-previous-test-run-record db run-id test-name item-path) > 33 (let* ((keys (db:get-keys db)) > 34 (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ", > 35 (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=? > 36 (keyvals #f)) > 37 ;; first look up the key values from the run selected by run-id > 38 (sqlite3:for-each-row > 39 (lambda (a . b) > 40 (set! keyvals (cons a b))) > 41 db > 42 (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") r > 43 (if (not keyvals) > 44 #f > 45 (let ((prev-run-ids '())) > 46 (apply sqlite3:for-each-row > 47 (lambda (id) > 48 (set! prev-run-ids (cons id prev-run-ids))) > 49 db > 50 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (app > 51 ;; for each run starting with the most recent look to see if there is > 52 ;; if found then return that matching test record > 53 (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " key > 54 (if (null? prev-run-ids) #f > 55 (let loop ((hed (car prev-run-ids)) > 56 (tal (cdr prev-run-ids))) > 57 (let ((results (db-get-tests-for-run db hed test-name item-path > 58 (debug:print 4 "Got tests for run-id " run-id ", test-name " t > 59 (if (and (null? results) > 60 (not (null? tal))) > 61 (loop (car tal)(cdr tal)) > 62 (if (null? results) #f > 63 (car results)))))))))) > 64 > 65 ;; get the previous records for when these tests were run where all keys match b > 66 ;; NB// Merge this with test:get-previous-test-run-records? This one looks for a > 67 ;; can use wildcards. > 68 (define (test:get-matching-previous-test-run-records db run-id test-name item-pa > 69 (let* ((keys (db:get-keys db)) > 70 (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ", > 71 (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=? > 72 (keyvals #f) > 73 (tests-hash (make-hash-table))) > 74 ;; first look up the key values from the run selected by run-id > 75 (sqlite3:for-each-row > 76 (lambda (a . b) > 77 (set! keyvals (cons a b))) > 78 db > 79 (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") r > 80 (if (not keyvals) > 81 '() > 82 (let ((prev-run-ids '())) > 83 (apply sqlite3:for-each-row > 84 (lambda (id) > 85 (set! prev-run-ids (cons id prev-run-ids))) > 86 db > 87 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (app > 88 ;; collect all matching tests for the runs then > 89 ;; extract the most recent test and return that. > 90 (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " key > 91 ", previous run ids found: " prev-run-ids) > 92 (if (null? prev-run-ids) '() ;; no previous runs? return null > 93 (let loop ((hed (car prev-run-ids)) > 94 (tal (cdr prev-run-ids))) > 95 (let ((results (db-get-tests-for-run db hed test-name item-path > 96 (debug:print 4 "Got tests for run-id " run-id ", test-name " t > 97 ", item-path " item-path " results: " (interspers > 98 ;; Keep only the youngest of any test/item combination > 99 (for-each > 100 (lambda (testdat) > 101 (let* ((full-testname (conc (db:test-get-testname testdat) > 102 (stored-test (hash-table-ref/default tests-hash fu > 103 (if (or (not stored-test) > 104 (and stored-test > 105 (> (db:test-get-event_time testdat)(db:test- > 106 ;; this test is younger, store it in the hash > 107 (hash-table-set! tests-hash full-testname testdat)))) > 108 results) > 109 (if (null? tal) > 110 (map cdr (hash-table->alist tests-hash)) ;; return a list > 111 (loop (car tal)(cdr tal)))))))))) > 112 > 113 (define (test-set-status! db run-id test-name state status itemdat-or-path comme > 114 (let* ((real-status status) > 115 (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list-> > 116 (testdat (db:get-test-info db run-id test-name item-path)) > 117 (test-id (if testdat (db:test-get-id testdat) #f)) > 118 (otherdat (if dat dat (make-hash-table))) > 119 ;; before proceeding we must find out if the previous test (where all k > 120 ;; was WAIVED if this test is FAIL > 121 (waived (if (equal? status "FAIL") > 122 (let ((prev-test (test:get-previous-test-run-record db ru > 123 (if prev-test ;; true if we found a previous test in th > 124 (let ((prev-status (db:test-get-status prev-test) > 125 (prev-state (db:test-get-state prev-test) > 126 (prev-comment (db:test-get-comment prev-test) > 127 (debug:print 4 "prev-status " prev-status ", prev > 128 (if (and (equal? prev-state "COMPLETED") > 129 (equal? prev-status "WAIVED")) > 130 prev-comment ;; waived is either the comment > 131 #f)) > 132 #f)) > 133 #f))) > 134 (if waived (set! real-status "WAIVED")) > 135 (debug:print 4 "real-status " real-status ", waived " waived ", status " sta > 136 > 137 ;; update the primary record IF state AND status are defined > 138 (if (and state status) > 139 (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strfti > 140 state real-status run-id test-name item-path)) > 141 > 142 ;; if status is "AUTO" then call rollup > 143 (if (and test-id state status (equal? status "AUTO")) > 144 (db:test-data-rollup db test-id)) > 145 > 146 ;; add metadata (need to do this way to avoid SQL injection issues) > 147 > 148 ;; :first_err > 149 ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) > 150 ;; (if val > 151 ;; (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AN > 152 ;; > 153 ;; ;; :first_warn > 154 ;; (let ((val (hash-table-ref/default otherdat ":first_warn" #f))) > 155 ;; (if val > 156 ;; (sqlite3:execute db "UPDATE tests SET first_warn=? WHERE run_id=? A > 157 > 158 (let ((category (hash-table-ref/default otherdat ":category" "")) > 159 (variable (hash-table-ref/default otherdat ":variable" "")) > 160 (value (hash-table-ref/default otherdat ":value" #f)) > 161 (expected (hash-table-ref/default otherdat ":expected" #f)) > 162 (tol (hash-table-ref/default otherdat ":tol" #f)) > 163 (units (hash-table-ref/default otherdat ":units" "")) > 164 (dcomment (hash-table-ref/default otherdat ":comment" ""))) > 165 (debug:print 4 > 166 "category: " category ", variable: " variable ", value: " val > 167 ", expected: " expected ", tol: " tol ", units: " units) > 168 (if (and value expected tol) ;; all three required > 169 (db:csv->test-data db test-id > 170 (conc category "," > 171 variable "," > 172 value "," > 173 expected "," > 174 tol "," > 175 units "," > 176 dcomment ",")))) > 177 > 178 ;; need to update the top test record if PASS or FAIL and this is a subtest > 179 (if (and (not (equal? item-path "")) > 180 (or (equal? status "PASS") > 181 (equal? status "WARN") > 182 (equal? status "FAIL") > 183 (equal? status "WAIVED") > 184 (equal? status "RUNNING"))) > 185 (begin > 186 (sqlite3:execute > 187 db > 188 "UPDATE tests > 189 SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND test > 190 pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND test > 191 WHERE run_id=? AND testname=? AND item_path='';" > 192 run-id test-name run-id test-name run-id test-name) > 193 (if (equal? status "RUNNING") ;; running takes priority over all other > 194 (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND t > 195 (sqlite3:execute > 196 db > 197 "UPDATE tests > 198 SET state=CASE WHEN (SELECT count(id) FROM tests WHERE ru > 199 'RUNNING' > 200 ELSE 'COMPLETED' END, > 201 status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_ > 202 WHERE run_id=? AND testname=? AND item_path='';" > 203 run-id test-name run-id test-name)))) > 204 (if (or (and (string? comment) > 205 (string-match (regexp "\\S+") comment)) > 206 waived) > 207 (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testn > 208 (if waived waived comment) run-id test-name item-path)) > 209 )) > 210 > 211 (define (test-set-log! db run-id test-name itemdat logf) > 212 (let ((item-path (item-list->path itemdat))) > 213 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testna > 214 logf run-id test-name item-path))) > 215 > 216 (define (test-set-toplog! db run-id test-name logf) > 217 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname > 218 logf run-id test-name)) > 219 > 220 (define (tests:summarize-items db run-id test-name force) > 221 ;; if not force then only update the record if one of these is true: > 222 ;; 1. logf is "log/final.log > 223 ;; 2. logf is same as outputfilename > 224 (let ((outputfilename (conc "megatest-rollup-" test-name ".html")) > 225 (orig-dir (current-directory)) > 226 (logf #f)) > 227 (sqlite3:for-each-row > 228 (lambda (path final_logf) > 229 (set! logf final_logf) > 230 (if (directory? path) > 231 (begin > 232 (print "Found path: " path) > 233 (change-directory path)) > 234 ;; (set! outputfilename (conc path "/" outputfilename))) > 235 (print "No such path: " path))) > 236 db > 237 "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item > 238 run-id test-name) > 239 (print "summarize-items with logf " logf) > 240 (if (or (equal? logf "logs/final.log") > 241 (equal? logf outputfilename) > 242 force) > 243 (begin > 244 (if (obtain-dot-lock outputfilename 1 20 30) ;; retry every second for > 245 (print "Obtained lock for " outputfilename) > 246 (print "Failed to obtain lock for " outputfilename)) > 247 (let ((oup (open-output-file outputfilename)) > 248 (counts (make-hash-table)) > 249 (statecounts (make-hash-table)) > 250 (outtxt "") > 251 (tot 0)) > 252 (with-output-to-port > 253 oup > 254 (lambda () > 255 (set! outtxt (conc outtxt "<html><title>Summary: " test-name > 256 "</title><body><h2>Summary for " test-name "< > 257 (sqlite3:for-each-row > 258 (lambda (id itempath state status run_duration logf comment) > 259 (hash-table-set! counts status (+ 1 (hash-table-ref/default c > 260 (hash-table-set! statecounts state (+ 1 (hash-table-ref/defau > 261 (set! outtxt (conc outtxt "<tr>" > 262 "<td><a href=\"" itempath "/" logf "\"> " > 263 "<td>" state "</td>" > 264 "<td><font color=" (common:get-color-from- > 265 ">" status "</font></td>" > 266 "<td>" (if (equal? comment "") > 267 "&nbsp;" > 268 comment) "</td>" > 269 "</tr>"))) > 270 db > 271 "SELECT id,item_path,state,status,run_duration,final_logf,comme > 272 run-id test-name) > 273 > 274 (print "<table><tr><td valign=\"top\">") > 275 ;; Print out stats for status > 276 (set! tot 0) > 277 (print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\" > 278 (for-each (lambda (state) > 279 (set! tot (+ tot (hash-table-ref statecounts state)) > 280 (print "<tr><td>" state "</td><td>" (hash-table-ref > 281 (hash-table-keys statecounts)) > 282 (print "<tr><td>Total</td><td>" tot "</td></tr></table>") > 283 (print "</td><td valign=\"top\">") > 284 ;; Print out stats for state > 285 (set! tot 0) > 286 (print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\" > 287 (for-each (lambda (status) > 288 (set! tot (+ tot (hash-table-ref counts status))) > 289 (print "<tr><td><font color=\"" (common:get-color-fr > 290 "</font></td><td>" (hash-table-ref counts sta > 291 (hash-table-keys counts)) > 292 (print "<tr><td>Total</td><td>" tot "</td></tr></table>") > 293 (print "</td></td></tr></table>") > 294 > 295 (print "<table cellspacing=\"0\" border=\"1\">" > 296 "<tr><td>Item</td><td>State</td><td>Status</td><td>Commen > 297 outtxt "</table></body></html>") > 298 (release-dot-lock outputfilename))) > 299 (close-output-port oup) > 300 (change-directory orig-dir) > 301 (test-set-toplog! db run-id test-name outputfilename) > 302 ))))) > 303 > 304 (define (get-all-legal-tests) > 305 (let* ((tests (glob (conc *toppath* "/tests/*"))) > 306 (res '())) > 307 (debug:print 4 "INFO: Looking at tests " (string-intersperse tests ",")) > 308 (for-each (lambda (testpath) > 309 (if (file-exists? (conc testpath "/testconfig")) > 310 (set! res (cons (last (string-split testpath "/")) res)))) > 311 tests) > 312 res)) > 313 > 314 (define (test:get-testconfig test-name system-allowed) > 315 (let* ((test-path (conc *toppath* "/tests/" test-name)) > 316 (test-configf (conc test-path "/testconfig")) > 317 (testexists (and (file-exists? test-configf)(file-read-access? test-c > 318 (if testexists > 319 (read-config test-configf #f system-allowed environ-patt: (if system-all > 320 "pre-launc > 321 #f)) > 322 #f))) > 323 > 324 ;; sort tests by priority and waiton > 325 ;; Move test specific stuff to a test unit FIXME one of these days > 326 (define (tests:sort-by-priority-and-waiton test-names) > 327 (let ((testdetails (make-hash-table)) > 328 (mungepriority (lambda (priority) > 329 (if priority > 330 (let ((tmp (any->number priority))) > 331 (if tmp tmp (begin (debug:print 0 "ERROR: bad pri > 332 0)))) > 333 (for-each (lambda (test-name) > 334 (let ((test-config (test:get-testconfig test-name #f))) > 335 (if test-config (hash-table-set! testdetails test-name test-co > 336 test-names) > 337 (sort > 338 (hash-table-keys testdetails) ;; avoid dealing with deleted tests, look at > 339 (lambda (a b) > 340 (let* ((tconf-a (hash-table-ref testdetails a)) > 341 (tconf-b (hash-table-ref testdetails b)) > 342 (a-waiton (config-lookup tconf-a "requirements" "waiton")) > 343 (b-waiton (config-lookup tconf-b "requirements" "waiton")) > 344 (a-priority (mungepriority (config-lookup tconf-a "requirements" " > 345 (b-priority (mungepriority (config-lookup tconf-b "requirements" " > 346 (if (and a-waiton (equal? a-waiton b)) > 347 #f ;; cannot have a which is waiting on b happening before b > 348 (if (and b-waiton (equal? b-waiton a)) > 349 #t ;; this is the correct order, b is waiting on a and b is bef > 350 (if (> a-priority b-priority) > 351 #t ;; if a is a higher priority than b then we are good to > 352 #f)))))))) > 353 > 354 > 355 ;;====================================================================== > 356 ;; test steps > 357 ;;====================================================================== > 358 > 359 (define (teststep-set-status! db run-id test-name teststep-name state-in status- > 360 (debug:print 4 "run-id: " run-id " test-name: " test-name) > 361 (let* ((state (check-valid-items "state" state-in)) > 362 (status (check-valid-items "status" status-in)) > 363 (item-path (item-list->path itemdat)) > 364 (testdat (db:get-test-info db run-id test-name item-path))) > 365 (debug:print 5 "testdat: " testdat) > 366 (if (and testdat ;; if the section exists then force specification BUG, I do > 367 (or (not state)(not status))) > 368 (debug:print 0 "WARNING: Invalid " (if status "status" "state") > 369 " value \"" (if status state-in status-in) "\", update your valid > 370 (if testdat > 371 (let ((test-id (test:get-id testdat))) > 372 ;; FIXME - this should not update the logfile unless it is specified. > 373 (sqlite3:execute db > 374 "INSERT OR REPLACE into test_steps (test_id,stepname,sta > 375 test-id teststep-name state-in status-in (if comment com > 376 (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> > 377 > 378 (define (test-get-kill-request db run-id test-name itemdat) > 379 (let* ((item-path (item-list->path itemdat)) > 380 (testdat (db:get-test-info db run-id test-name item-path))) > 381 (equal? (test:get-state testdat) "KILLREQ"))) > 382 > 383 (define (test-set-meta-info db run-id testname itemdat) > 384 (let ((item-path (item-list->path itemdat)) > 385 (cpuload (get-cpu-load)) > 386 (hostname (get-host-name)) > 387 (diskfree (get-df (current-directory))) > 388 (uname (get-uname "-srvpio")) > 389 (runpath (current-directory))) > 390 (sqlite3:execute db "UPDATE tests SET host=?,cpuload=?,diskfree=?,uname=?,ru > 391 hostname > 392 cpuload > 393 diskfree > 394 uname > 395 runpath > 396 run-id > 397 testname > 398 item-path))) > 399 > 400 (define (test-update-meta-info db run-id testname itemdat minutes cpuload diskfr > 401 (let ((item-path (item-list->path itemdat))) > 402 (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (se > 403 ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) > 404 ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) > 405 ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) > 406 (sqlite3:execute > 407 db > 408 "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE > 409 cpuload > 410 diskfree > 411 minutes > 412 run-id > 413 testname > 414 item-path))) > 415