Check-in [3aeabde95d]
Not logged in
Overview
SHA1 Hash:3aeabde95dcc1fde02d12b9b09f33e1bd0c0e0f9
Date: 2011-11-20 22:36:08
User: matt
Comment:commit of re-hacked run code. completely torn to shreds and rewritten
Timelines: family | ancestors | descendants | both | reorg-runs-code
Diffs: root of this branch
Downloads: Tarball | ZIP archive
Other Links: files | file ages | manifest
Tags And Properties
Changes

Modified configf.scm from [ef264b880e908b66] to [e31d2a9565823c2f].

74 (blank-l-rx _ (loop (read-line inp) curr-section 74 (blank-l-rx _ (loop (read-line inp) curr-section 75 (include-rx ( x include-file ) (begin 75 (include-rx ( x include-file ) (begin 76 (read-config include-file res al 76 (read-config include-file res al 77 (loop (read-line inp) curr-secti 77 (loop (read-line inp) curr-secti 78 (section-rx ( x section-name ) (loop (read-line inp) section-name 78 (section-rx ( x section-name ) (loop (read-line inp) section-name 79 (key-sys-pr ( x key cmd ) (if allow-system 79 (key-sys-pr ( x key cmd ) (if allow-system 80 (let ((alist (hash-table-ref/d 80 (let ((alist (hash-table-ref/d > 81 (val-proc (lambda () 81 (val (let* ((cmdres ( | 82 (let* ((cmdr 82 (status ( | 83 (stat 83 (res ( | 84 (res 84 (if (not (eq? s | 85 (if (not ( 85 (begin | 86 (begin 86 (debug:pr | 87 (deb 87 (exit 1)) | 88 (exi 88 (if (null? res) | 89 (if (null? 89 "" | 90 "" 90 (string-int | 91 (strin 91 (hash-table-set! res curr-se 92 (hash-table-set! res curr-se 92 (config:ass | 93 (config:ass > 94 > 95 > 96 > 97 93 (loop (read-line inp) curr-s 98 (loop (read-line inp) curr-s 94 (loop (read-line inp) curr-sec 99 (loop (read-line inp) curr-sec 95 (key-val-pr ( x key val ) (let* ((alist (hash-table-ref/de 100 (key-val-pr ( x key val ) (let* ((alist (hash-table-ref/de 96 (envar (and environ-patt 101 (envar (and environ-patt 97 (realval (if envar 102 (realval (if envar 98 (config:eval-st 103 (config:eval-st 99 val))) 104 val)))

Modified db.scm from [65214cf6f39701d4] to [c39ab57eb703aaa5].

111 owner TEXT DEFAULT '', 111 owner TEXT DEFAULT '', 112 description TEXT DEFAULT '', 112 description TEXT DEFAULT '', 113 reviewed TIMESTAMP, 113 reviewed TIMESTAMP, 114 iterated TEXT DEFAULT '', 114 iterated TEXT DEFAULT '', 115 avg_runtime REAL, 115 avg_runtime REAL, 116 avg_disk REAL, 116 avg_disk REAL, 117 tags TEXT DEFAULT '', 117 tags TEXT DEFAULT '', > 118 jobgroup TEXT DEFAULT 'default', 118 CONSTRAINT test_meta_constraint UNIQUE (testname 119 CONSTRAINT test_meta_constraint UNIQUE (testname 119 (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER 120 (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER 120 test_id INTEGER, 121 test_id INTEGER, 121 category TEXT DEFAULT '', 122 category TEXT DEFAULT '', 122 variable TEXT, 123 variable TEXT, 123 value REAL, 124 value REAL, 124 expected REAL, 125 expected REAL, ................................................................................................................................................................................ 205 (db:set-var db "MEGATEST_VERSION" 1.27) 206 (db:set-var db "MEGATEST_VERSION" 1.27) 206 (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT ' 207 (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT ' 207 (patch-db)) 208 (patch-db)) 208 ((< mver 1.29) 209 ((< mver 1.29) 209 (db:set-var db "MEGATEST_VERSION" 1.29) 210 (db:set-var db "MEGATEST_VERSION" 1.29) 210 (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAU 211 (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAU 211 (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT ' 212 (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT ' > 213 ((< mver 1.36) > 214 (db:set-var db "MEGATEST_VERSION" 1.36) > 215 (sqlite3:execute db "ALTER TABLER test_meta ADD COLUMN jobgroup TEXT DEFA 212 ((< mver megatest-version) 216 ((< mver megatest-version) 213 (db:set-var db "MEGATEST_VERSION" megatest-version)))))) 217 (db:set-var db "MEGATEST_VERSION" megatest-version)))))) 214 218 215 ;;====================================================================== 219 ;;====================================================================== 216 ;; meta get and set vars 220 ;; meta get and set vars 217 ;;====================================================================== 221 ;;====================================================================== 218 222 ................................................................................................................................................................................ 414 (let ((res 0)) 418 (let ((res 0)) 415 (sqlite3:for-each-row 419 (sqlite3:for-each-row 416 (lambda (count) 420 (lambda (count) 417 (set! res count)) 421 (set! res count)) 418 db 422 db 419 "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' 423 "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' 420 res)) 424 res)) > 425 > 426 (define (db:get-count-tests-running-in-jobgroup db jobgroup) > 427 (if (not jobgroup) > 428 0 ;; > 429 (let ((res 0)) > 430 (sqlite3:for-each-row > 431 (lambda (count) > 432 (set! res count)) > 433 db > 434 "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCH > 435 AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?;" > 436 jobgroup) > 437 res))) 421 438 422 ;; done with run when: 439 ;; done with run when: 423 ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING 440 ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING 424 (define (db:estimated-tests-remaining db run-id) 441 (define (db:estimated-tests-remaining db run-id) 425 (let ((res 0)) 442 (let ((res 0)) 426 (sqlite3:for-each-row 443 (sqlite3:for-each-row 427 (lambda (count) 444 (lambda (count) ................................................................................................................................................................................ 692 (for-each (lambda (test) 709 (for-each (lambda (test) 693 (if (equal? waitontest-name (db:test-get-testn 710 (if (equal? waitontest-name (db:test-get-testn 694 (begin 711 (begin 695 (set! ever-seen #t) 712 (set! ever-seen #t) 696 (if (not (and (equal? (db:test-get-state 713 (if (not (and (equal? (db:test-get-state 697 (member (db:test-get-statu 714 (member (db:test-get-statu 698 (set! result (cons waitontest-name r 715 (set! result (cons waitontest-name r > 716 tests) > 717 (if (not ever-seen)(set! result (cons waitontest-name resu > 718 waiton) > 719 (delete-duplicates result)))) > 720 > 721 ;; the new prereqs calculation, looks also at itempath if specified > 722 ;; all prereqs must be met: > 723 ;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAI > 724 ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, > 725 (define (db:get-prereqs-not-met db run-id waiton ref-item-path) > 726 (if (null? waiton) > 727 '() > 728 (let* ((unmet-pre-reqs '()) > 729 (tests (db-get-tests-for-run db run-id #f #f '() '())) > 730 (result '())) > 731 (for-each (lambda (waitontest-name) > 732 (let ((ever-seen #f)) > 733 (for-each (lambda (test) > 734 (if (equal? waitontest-name (db:test-get-testn > 735 (let* ((state (db:test-get-state t > 736 (status (db:test-get-status > 737 (item-path (db:test-get-item-pa > 738 (is-completed (equal? state "COMPL > 739 (is-ok (member status '("PA > 740 (same-itempath (equal? ref-item-pat > 741 (set! ever-seen #t) > 742 (if (or ( > 743 (set! result (cons waitontest-name r 699 tests) 744 tests) 700 (if (not ever-seen)(set! result (cons waitontest-name resu 745 (if (not ever-seen)(set! result (cons waitontest-name resu 701 waiton) 746 waiton) 702 (delete-duplicates result)))) 747 (delete-duplicates result)))) 703 748 704 ;;====================================================================== 749 ;;====================================================================== 705 ;; Extract ods file from the db 750 ;; Extract ods file from the db

Modified megatest-version.scm from [c9e5e7d31e1201ff] to [27dcca54210e5a68].

1 ;; Always use two digit decimal 1 ;; Always use two digit decimal 2 ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. 2 ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. 3 3 4 (declare (unit megatest-version)) 4 (declare (unit megatest-version)) 5 5 6 (define megatest-version 1.34) | 6 (define megatest-version 1.36) 7 7

Modified runs.scm from [253a55cec5467d66] to [9e5179a7af8cc41e].

92 92 93 (define (set-item-env-vars itemdat) 93 (define (set-item-env-vars itemdat) 94 (for-each (lambda (item) 94 (for-each (lambda (item) 95 (debug:print 2 "setenv " (car item) " " (cadr item)) 95 (debug:print 2 "setenv " (car item) " " (cadr item)) 96 (setenv (car item) (cadr item))) 96 (setenv (car item) (cadr item))) 97 itemdat)) 97 itemdat)) 98 98 99 (define (runs:can-run-more-tests db) | 99 (define (runs:can-run-more-tests db test-record) > 100 (let* ((tconfig (tests:testqueue-get-testconfig test-record)) > 101 (jobgroup (config-lookup tconfig "requirements" "jobgrou 100 (let ((num-running (db:get-count-tests-running db)) | 102 (num-running (db:get-count-tests-running db)) > 103 (num-running-in-jobgroup (db:get-count-tests-running-in-jobgroup db job 101 (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_ | 104 (max-concurrent-jobs (config-lookup *configdat* "setup" "max_co > 105 (job-group-limit (config-lookup *configdat* "jobgroups" jobgrou 102 (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " 106 (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " 103 (if (not (eq? 0 *globalexitstatus*)) 107 (if (not (eq? 0 *globalexitstatus*)) 104 #f 108 #f > 109 (let ((can-not-run-more (cond 105 (if (or (not max-concurrent-jobs) | 110 ;; if max-concurrent-jobs is set and the number > 111 ;; than it than cannot run more jobs 106 (and max-concurrent-jobs | 112 ((and max-concurrent-jobs 107 (string->number max-concurrent-jobs) | 113 (string->number max-concurrent-jobs) 108 (not (>= num-running (string->number max-concurrent-jobs))) | 114 (>= num-running (string->number max-concu 109 #t < 110 (begin < 111 (debug:print 0 "WARNING: Max running jobs exceeded, current number | 115 (debug:print 0 "WARNING: Max running jobs exce 112 ", max_concurrent_jobs: " max-concurrent-jobs) | 116 ", max_concurrent_jobs: " max-con > 117 #t) > 118 ;; if job-group-limit is set and number of jobs > 119 ;; than the limit then cannot run more jobs of > 120 ((and job-group-limit > 121 (>= num-running-in-jobgroup job-group-lim > 122 (debug:print 1 "WARNING: number of jobs " num- > 123 " in " jobgroup " exceeded, will > 124 #t) 113 #f))))) | 125 (else #f)))) 114 < > 126 (not can-not-run-more))))) 115 127 116 ;;====================================================================== 128 ;;====================================================================== 117 ;; New methodology. These routines will replace the above in time. For 129 ;; New methodology. These routines will replace the above in time. For 118 ;; now the code is duplicated. This stuff is initially used in the monitor 130 ;; now the code is duplicated. This stuff is initially used in the monitor 119 ;; based code. 131 ;; based code. 120 ;;====================================================================== 132 ;;====================================================================== 121 133 ................................................................................................................................................................................ 153 ;; This is a duplicate of run-tests (which has been deprecated). Use this one in 165 ;; This is a duplicate of run-tests (which has been deprecated). Use this one in 154 ;; keyvals 166 ;; keyvals 155 (define (runs:run-tests db target runname test-patts item-patts user flags) 167 (define (runs:run-tests db target runname test-patts item-patts user flags) 156 (let* ((keys (db-get-keys db)) 168 (let* ((keys (db-get-keys db)) 157 (keyvallst (keys:target->keyval keys target)) 169 (keyvallst (keys:target->keyval keys target)) 158 (run-id (runs:register-run db keys keyvallst runname "new" "n/a" u 170 (run-id (runs:register-run db keys keyvallst runname "new" "n/a" u 159 (deferred '()) ;; delay running these since they have a waiton claus 171 (deferred '()) ;; delay running these since they have a waiton claus > 172 ;; keepgoing is the defacto modality now, will add hit-n-run a bit late 160 (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) | 173 ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) 161 (test-names '()) 174 (test-names '()) 162 (runconfigf (conc *toppath* "/runconfigs.config")) 175 (runconfigf (conc *toppath* "/runconfigs.config")) 163 (required-tests '()) 176 (required-tests '()) 164 (test-records (make-hash-table))) 177 (test-records (make-hash-table))) 165 178 166 (set-megatest-env-vars db run-id) ;; these may be needed by the launching pr 179 (set-megatest-env-vars db run-id) ;; these may be needed by the launching pr 167 180 ................................................................................................................................................................................ 194 ;; have to delete test records where NOT_STARTED since they can cause 207 ;; have to delete test records where NOT_STARTED since they can cause 195 ;; get stuck due to becoming inaccessible from a failed test. I.e. if 208 ;; get stuck due to becoming inaccessible from a failed test. I.e. if 196 ;; on test A but test B reached the point on being registered as NOT_S 209 ;; on test A but test B reached the point on being registered as NOT_S 197 ;; A failed for some reason then on re-run using -keepgoing the run ca 210 ;; A failed for some reason then on re-run using -keepgoing the run ca 198 (db:delete-tests-in-state db run-id "NOT_STARTED") 211 (db:delete-tests-in-state db run-id "NOT_STARTED") 199 (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED 212 (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED 200 213 201 (set! *passnum* (+ *passnum* 1)) < 202 < 203 ;; now add non-directly referenced dependencies (i.e. waiton) 214 ;; now add non-directly referenced dependencies (i.e. waiton) 204 (if (not (null? test-names)) 215 (if (not (null? test-names)) 205 (let loop ((hed (car test-names)) 216 (let loop ((hed (car test-names)) 206 (tal (cdr test-names))) | 217 (tal (cdr test-names))) ;; 'return-procs tells the co 207 (let* ((config (test:get-testconfig hed #f)) | 218 (let* ((config (test:get-testconfig hed 'return-procs)) 208 (waitons (string-split (let ((w (config-lookup config "requirem 219 (waitons (string-split (let ((w (config-lookup config "requirem 209 (if w w ""))))) | 220 (if w w "")))) > 221 (items (items:get-items-from-config config))) 210 (if (not (hash-table-ref/default test-records hed #f)) 222 (if (not (hash-table-ref/default test-records hed #f)) 211 (hash-table-set! test-records hed (vector hed config waitons (co 223 (hash-table-set! test-records hed (vector hed config waitons (co 212 (for-each 224 (for-each 213 (lambda (waiton) 225 (lambda (waiton) 214 (if (and waiton (not (member waiton test-names))) 226 (if (and waiton (not (member waiton test-names))) 215 (begin 227 (begin 216 (set! required-tests (cons waiton required-tests)) 228 (set! required-tests (cons waiton required-tests)) ................................................................................................................................................................................ 218 waitons) 230 waitons) 219 (let ((remtests (delete-duplicates (append waitons tal)))) 231 (let ((remtests (delete-duplicates (append waitons tal)))) 220 (if (not (null? remtests)) 232 (if (not (null? remtests)) 221 (loop (car remtests)(cdr remtests))))))) 233 (loop (car remtests)(cdr remtests))))))) 222 234 223 (if (not (null? required-tests)) 235 (if (not (null? required-tests)) 224 (debug:print 1 "INFO: Adding " required-tests " to the run queue")) 236 (debug:print 1 "INFO: Adding " required-tests " to the run queue")) > 237 ;; NOTE: these are all parent tests, items are not expanded yet. > 238 (runs:run-tests-queue test-records))) 225 239 > 240 (define (runs:run-tests-queue test-records keyvallist) 226 ;; At this point the list of parent tests is expanded 241 ;; At this point the list of parent tests is expanded 227 ;; NB// Should expand items here and then insert into the run queue. 242 ;; NB// Should expand items here and then insert into the run queue. 228 (let loop ((numtimes 0)) | 243 (let ((sorted-testnames (tests:sort-by-priority-and-waiton test-records))) 229 (for-each | 244 (let loop (; (numtimes 0) ;; shouldn't need this 230 (lambda (test-record) | 245 (hed (car sorted-test-names)) > 246 (tal (cdr sorted-test-names))) > 247 (let* ((test-record (hash-table-ref test-records hed)) > 248 (tconfig (tests:testqueue-get-testconfig test-record)) > 249 (waitons (tests:testqueue-get-waitons test-record)) > 250 (priority (tests:testqueue-get-priority test-record)) 231 ;; need to inspect the items field tests:testqueue-get-items | 251 (itemdat (tests:testqueue-get-itemdat test-record)) 232 ;; < 233 ;; if #f then no items for this test, check prereqs and launch < 234 ;; < 235 ;; else if list, then have items < 236 ;; < 237 ;; if proc then eval it. | 252 (items (tests:testqueue-get-items test-record)) 238 ;; < > 253 (item-path (item-list->path itemdat))) 239 (let ((items (items:get-items-from-config tconfig))) | 254 (cond > 255 ((not items) ;; when false the test is ok to be handed off to launch 240 (if (runs:can-run-more-tests db test-record) ;; now needs to look at th | 256 (let ((have-resources (runs:can-run-more-tests db test-record)) ;; > 257 (prereqs-not-met (db:get-prereqs-not-met db run-id waiton item > 258 (if (and have-resources > 259 (null? prereqs-not-met)) > 260 ;; no loop - drop though and use the loop at the bottom 241 (run:test db run-id runname test-name keyvallst item-patts flags) | 261 (run:test db run-id runname keyvallst test-record flags) > 262 ;; else the run is stuck, temporarily or permanently > 263 (let ((newtal (append tal (list hed)))) > 264 ;; couldn't run, take a breather > 265 (thread-sleep! 1) > 266 (loop (car tal)(cdr tal)))))) > 267 > 268 ;; case where an items came in as a list been processed > 269 ((and (list? items) ;; thus we know our items are already calcula > 270 (not itemdat)) ;; and not yet expanded into the list of thing > 271 (if (>= *verbosity* 1)(pp items)) > 272 ;; (if (>= *verbosity* 5) > 273 ;; (begin > 274 ;; (print "items: ") (pp (item-assoc->item-list items)) > 275 ;; (print "itemstable: ")(pp (item-table->item-list itemstable > 276 (for-each > 277 (lambda (my-itemdat) > 278 (let* ((new-test-record (vector-copy! test-record (make-tests:tes > 279 (my-item-path (item-list->path my-itemdat)) > 280 (item-matches (if item-patts ;; here we are filterin > 281 (let ((res #f)) ;; look through all the > 282 (for-each > 283 (lambda (patt) > 284 (if (string-search (glob->regexp > 285 (string-transla > 286 item-path) > 287 (set! res #t))) > 288 (string-split item-patts ",")) > 289 res) 242 )) | 290 #t))) 243 (tests:sort-by-priority-and-waiton test-records)) < 244 ;; (run-waiting-tests db) < 245 (if keepgoing < 246 (let ((estrem (db:estimated-tests-remaining db run-id))) < 247 (if (and (> estrem 0) < 248 (eq? *globalexitstatus* 0)) < > 291 (if item-matches ;; yes, we want to process this item 249 (begin | 292 (begin 250 (debug:print 1 "Keep going, estimated " estrem " tests remaini < > 293 (tests:testqueue-set-items! new-test-record #f) > 294 (tests:testqueue-set-itemdat! new-test-record my-itemdat) > 295 (set! tal (cons (conc hed "/" my-item-path) tal)))))) ;; > 296 items) > 297 (loop (car tal)(cdr tal))) > 298 > 299 ;; if items is a proc then need to evaluate, get the list and loop - > 300 ;; resources exist to kick off the job > 301 ((procedure? items) > 302 (if (runs:can-run-more-tests db test-record) > 303 (let ((items-list (items))) > 304 (if (list? items-list) > 305 (begin > 306 (tests:testqueue-set-items test-record items-list) > 307 (loop hed tal)) > 308 (begin > 309 (debug:print 0 "ERROR: The proc from reading the setup d > 310 (exit 1)))) > 311 (let ((newtal (append tal (list hed)))) > 312 ;; if can't run more tests, lets take a breather 251 (thread-sleep! 3) | 313 (thread-sleep! 1) 252 (run-waiting-tests db) < 253 (loop (+ numtimes 1))))))))) < > 314 (loop (car newtal)(cdr newtal))))) 254 | 315 > 316 ;; this case should not happen, added to help catch any bugs > 317 ((and (list? items) itemdat) > 318 (debug:print 0 "ERROR: Should not have a list of items in a test and > 319 (exit 1))) > 320 > 321 ;; we get here on "drop through" - loop for next test in queue > 322 (if (null? tal) > 323 (debug:print 1 "INFO: All tests launched") > 324 (loop (car tal)(cdr tal))))))) > 325 255 (define (run:test db run-id runname test-name keyvallst item-patts flags) | 326 (define (run:test db run-id runname keyvallst test-record flags) 256 (debug:print 1 "Launching test " test-name) 327 (debug:print 1 "Launching test " test-name) 257 ;; All these vars might be referenced by the testconfig file reader 328 ;; All these vars might be referenced by the testconfig file reader 258 (setenv "MT_TEST_NAME" test-name) ;; 329 (setenv "MT_TEST_NAME" test-name) ;; 259 (setenv "MT_RUNNAME" runname) 330 (setenv "MT_RUNNAME" runname) 260 (set-megatest-env-vars db run-id) ;; these may be needed by the launching proc 331 (set-megatest-env-vars db run-id) ;; these may be needed by the launching proc 261 (change-directory *toppath*) 332 (change-directory *toppath*) > 333 (let* ((test-name (tests:testqueue-get-testname test-record)) 262 (let* ((test-path (conc *toppath* "/tests/" test-name)) ;; could use test:g | 334 (test-path (conc *toppath* "/tests/" test-name)) ;; could use test:g 263 (test-configf (conc test-path "/testconfig")) < 264 (testexists (and (file-exists? test-configf)(file-read-access? test-c | 335 (test-conf (tests:testqueue-get-testconfig test-record)) 265 (test-conf (if testexists (read-config test-configf #f #t) (make-has | 336 (itemdat (tests:testqueue-get-itemdat test-record)) 266 (waiton (let ((w (config-lookup test-conf "requirements" "waiton" < 267 (if (string? w)(string-split w)'()))) < 268 (force (hash-table-ref/default flags "-force" #f)) 337 (force (hash-table-ref/default flags "-force" #f)) 269 (rerun (hash-table-ref/default flags "-rerun" #f)) 338 (rerun (hash-table-ref/default flags "-rerun" #f)) 270 (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) | 339 (keepgoing (hash-table-ref/default flags "-keepgoing" #f))) 271 ;; Are these tags still used? I don't think so... < 272 ;;(tags (let ((t (config-lookup test-conf "setup" "tags"))) < 273 ;; ;; we want our tags to be separated by commas and fully < 274 ;; ;; so that queries with "like" can tie to the commas at < 275 ;; ;; while also allowing the end user to freely use space < 276 ;; (if (string? t)(string-substitute (regexp "[,\\s]+") ", < 277 ;; '())))) < 278 ) | 340 279 (if (not testexists) < 280 ;; if the test is ill defined spit out an error but keep going (differen < 281 (debug:print 0 "ERROR: Can't find config file " test-configf) < 282 ;; put top vars into convenient variables and open the db < 283 (let* (;; db is always at *toppath*/db/megatest.db < 284 (items (hash-table-ref/default test-conf "items" '())) < 285 (itemstable (hash-table-ref/default test-conf "itemstable" '())) < 286 (allitems (if (or (not (null? items))(not (null? itemstable))) < 287 (append (item-assoc->item-list items) < 288 (item-table->item-list itemstable)) < 289 '(())))) ;; a list with one null list is a test < 290 ;; (runconfigf (conc *toppath* "/runconfigs.config"))) < 291 (debug:print 1 "items: ") < 292 (if (>= *verbosity* 1)(pp allitems)) < 293 (if (>= *verbosity* 5) < 294 (begin < 295 (print "items: ")(pp (item-assoc->item-list items)) < 296 (print "itemstable: ")(pp (item-table->item-list itemstable)))) < 297 < 298 ;; Comments are loaded by the test run, not at launch time (in general < 299 ;;(if (args:get-arg "-m") < 300 ;; (db:set-comment-for-run db run-id (args:get-arg "-m"))) < 301 < 302 ;; Here is where the test_meta table is best updated | 341 ;; Here is where the test_meta table is best updated 303 (runs:update-test_meta db test-name test-conf) | 342 (runs:update-test_meta db test-name test-conf) 304 | 343 305 ;; braindead work-around for poorly specified allitems list BUG!!! FIX < 306 (if (null? allitems)(set! allitems '(()))) < 307 (let loop ((itemdat (car allitems)) < 308 (tal (cdr allitems))) < 309 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") | 344 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season 310 ;; Handle lists of items < 311 (let* ((item-path (item-list->path itemdat)) ;; (string-interspe | 345 (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map 312 (new-test-path (string-intersperse (cons test-path (map cadr | 346 (new-test-path (string-intersperse (cons test-path (map cadr itemdat) 313 (new-test-name (if (equal? item-path "") test-name (conc test | 347 (new-test-name (if (equal? item-path "") test-name (conc test-name "/ 314 (testdat #f) | 348 (testdat #f) 315 (num-running (db:get-count-tests-running db)) < 316 (max-concurrent-jobs (config-lookup *configdat* "setup" "max_ < 317 (parent-test (and (not (null? items))(equal? item-path ""))) < 318 (single-test (and (null? items) (equal? item-path ""))) < 319 (item-test (not (equal? item-path ""))) < 320 ;; look through all the item-patts if defined, format is patt < 321 (item-matches (if item-patts < 322 (let ((res #f)) < 323 (for-each < 324 (lambda (patt) < 325 (if (string-search (glob->regexp < 326 (string-translate < 327 item-path) < 328 (set! res #t))) < 329 (string-split item-patts ",")) < 330 res) < 331 #t))) < 332 (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num- < 333 (if (and item-matches (runs:can-run-more-tests db)) < 334 (begin < 335 (let loop2 ((ts (db:get-test-info db run-id test-name item-p | 349 (test-info (db:get-test-info db run-id test-name item-path))) 336 (ct 0)) < 337 (if (and (not ts) < 338 (< ct 10)) < 339 (begin < 340 (register-test db run-id test-name item-path) | 350 (if (not test-info)(register-test db run-id test-name item-path)) 341 ;; Why did I set the comment here?!? POSSIBLE BUG BU < 342 ;; (db:test-set-comment db run-id test-name item-pat < 343 (loop2 (db:get-test-info db run-id test-name item-pa < 344 (+ ct 1))) < 345 (if ts < 346 (set! testdat ts) < 347 (begin < 348 (debug:print 0 "WARNING: Couldn't register test < 349 (if (not (null? tal)) < 350 (loop (car tal)(cdr tal))))))) < 351 (change-directory test-path) | 351 (change-directory test-path) 352 ;; this block is here only to inform the user early on < 353 < 354 ;; Moving this to the run calling block < 355 < 356 ;; (if (file-exists? runconfigf) < 357 ;; (setup-env-defaults db runconfigf run-id *already-see < 358 ;; (debug:print 0 "WARNING: You do not have a run config < 359 (debug:print 4 "run-id: " run-id " test-name: " test-name " | 352 (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " i 360 (case (if force ;; (args:get-arg "-force") | 353 (case (if force ;; (args:get-arg "-force") 361 'NOT_STARTED | 354 'NOT_STARTED 362 (if testdat | 355 (if testdat 363 (string->symbol (test:get-state testdat)) | 356 (string->symbol (test:get-state testdat)) 364 'failed-to-insert)) | 357 'failed-to-insert)) 365 ((failed-to-insert) | 358 ((failed-to-insert) 366 (debug:print 0 "ERROR: Failed to insert the record into t | 359 (debug:print 0 "ERROR: Failed to insert the record into the db")) 367 ((NOT_STARTED COMPLETED) | 360 ((NOT_STARTED COMPLETED) 368 (debug:print 6 "Got here, " (test:get-state testdat)) | 361 (debug:print 6 "Got here, " (test:get-state testdat)) 369 (let ((runflag #f)) | 362 (let ((runflag #f)) 370 (cond | 363 (cond 371 ;; i.e. this is the parent test to a suite of items, n < 372 (parent-test < 373 (set! runflag #f)) < 374 ;; -force, run no matter what | 364 ;; -force, run no matter what 375 (force (set! runflag #t)) | 365 (force (set! runflag #t)) 376 ;; NOT_STARTED, run no matter what | 366 ;; NOT_STARTED, run no matter what 377 ((equal? (test:get-state testdat) "NOT_STARTED")(set! | 367 ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t)) 378 ;; not -rerun and PASS, WARN or CHECK, do no run | 368 ;; not -rerun and PASS, WARN or CHECK, do no run 379 ((and (or (not rerun) | 369 ((and (or (not rerun) 380 keepgoing) | 370 keepgoing) 381 (member (test:get-status testdat) '("PASS" "WARN | 371 (member (test:get-status testdat) '("PASS" "WARN" "CHECK"))) 382 (set! runflag #f)) | 372 (set! runflag #f)) 383 ;; -rerun and status is one of the specifed, run it | 373 ;; -rerun and status is one of the specifed, run it 384 ((and rerun | 374 ((and rerun 385 (let ((rerunlst (string-split rerun ","))) ;; FA | 375 (let ((rerunlst (string-split rerun ","))) ;; FAIL, 386 (member (test:get-status testdat) rerunlst))) | 376 (member (test:get-status testdat) rerunlst))) 387 (set! runflag #t)) | 377 (set! runflag #t)) 388 ;; -keepgoing, do not rerun FAIL | 378 ;; -keepgoing, do not rerun FAIL 389 ((and keepgoing | 379 ((and keepgoing 390 (member (test:get-status testdat) '("FAIL"))) | 380 (member (test:get-status testdat) '("FAIL"))) 391 (set! runflag #f)) | 381 (set! runflag #f)) 392 ((and (not rerun) | 382 ((and (not rerun) 393 (member (test:get-status testdat) '("FAIL" "n/a" | 383 (member (test:get-status testdat) '("FAIL" "n/a"))) 394 (set! runflag #t)) | 384 (set! runflag #t)) 395 (else (set! runflag #f))) | 385 (else (set! runflag #f))) 396 (debug:print 6 "RUNNING => runflag: " runflag " STATE: | 386 (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-st 397 (if (not runflag) | 387 (if (not runflag) 398 (if (not parent-test) | 388 (if (not parent-test) 399 (debug:print 1 "NOTE: Not starting test " new-t | 389 (debug:print 1 "NOTE: Not starting test " new-test-name " as 400 (let* ((get-prereqs-cmd (lambda () | 390 (let* ((get-prereqs-cmd (lambda () 401 (db-get-prereqs-not-met d | 391 (db-get-prereqs-not-met db run-id waito 402 (launch-cmd (lambda () | 392 (launch-cmd (lambda () 403 (launch-test db run-id ru | 393 (launch-test db run-id runname test-con 404 (testrundat (list get-prereqs-cmd launc | 394 (testrundat (list get-prereqs-cmd launch-cmd))) 405 (if (or force | 395 (if (or force 406 (let ((preqs-not-yet-met ((car testrundat | 396 (let ((preqs-not-yet-met ((car testrundat)))) 407 (debug:print 2 "Preqrequesites for " te | 397 (debug:print 2 "Preqrequesites for " test-name ": " p 408 (null? preqs-not-yet-met))) ;; are ther | 398 (null? preqs-not-yet-met))) ;; are there any tests th 409 (if (not ((cadr testrundat))) ;; this is the | 399 (if (not ((cadr testrundat))) ;; this is the line that laun 410 (begin | 400 (begin 411 (print "ERROR: Failed to launch the tes | 401 (print "ERROR: Failed to launch the test. Exiting as 412 (set! *globalexitstatus* 1) ;; | 402 (set! *globalexitstatus* 1) ;; 413 (process-signal (current-process-id) si | 403 (process-signal (current-process-id) signal/kill) 414 ;(exit 1) | 404 ;(exit 1) 415 )) | 405 )) 416 (if (not keepgoing) | 406 (if (not keepgoing) 417 (hash-table-set! *waiting-queue* new-test | 407 (hash-table-set! *waiting-queue* new-test-name testrund 418 ((KILLED) | 408 ((KILLED) 419 (debug:print 1 "NOTE: " new-test-name " is already runnin | 409 (debug:print 1 "NOTE: " new-test-name " is already running or was expli 420 ((LAUNCHED REMOTEHOSTSTART RUNNING) | 410 ((LAUNCHED REMOTEHOSTSTART RUNNING) 421 (if (> (- (current-seconds)(+ (db:test-get-event_time tes | 411 (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) 422 (db:test-get-run_duration t | 412 (db:test-get-run_duration testdat))) 423 100) ;; i.e. no update for more than 100 seconds | 413 600) ;; i.e. no update for more than 600 seconds 424 (begin | 414 (begin 425 (debug:print 0 "WARNING: Test " test-name " appears | 415 (debug:print 0 "WARNING: Test " test-name " appears to be dead. F 426 (test-set-status! db run-id test-name "INCOMPLETE" | 416 (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" i 427 (debug:print 2 "NOTE: " test-name " is already runnin | 417 (debug:print 2 "NOTE: " test-name " is already running"))) 428 (else (debug:print 0 "ERROR: Failed to launch test " | 418 (else (debug:print 0 "ERROR: Failed to launch test " new-test-name 429 (if (not (null? tal)) < 430 (loop (car tal)(cdr tal))))))))) < 431 419 432 ;;====================================================================== 420 ;;====================================================================== 433 ;; END OF NEW STUFF 421 ;; END OF NEW STUFF 434 ;;====================================================================== 422 ;;====================================================================== 435 423 436 (define (get-dir-up-n dir . params) 424 (define (get-dir-up-n dir . params) 437 (let ((dparts (string-split dir "/")) 425 (let ((dparts (string-split dir "/")) ................................................................................................................................................................................ 604 (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runn 592 (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runn 605 (let* (; (keyvalllst (keys:target->keyval keys target)) 593 (let* (; (keyvalllst (keys:target->keyval keys target)) 606 (new-run-id (runs:register-run db keys keyvallst runname "new" "n/ 594 (new-run-id (runs:register-run db keys keyvallst runname "new" "n/ 607 (prev-tests (test:get-matching-previous-test-run-records db new-ru 595 (prev-tests (test:get-matching-previous-test-run-records db new-ru 608 (curr-tests (db-get-tests-for-run db new-run-id "%" "%" '() '())) 596 (curr-tests (db-get-tests-for-run db new-run-id "%" "%" '() '())) 609 (curr-tests-hash (make-hash-table))) 597 (curr-tests-hash (make-hash-table))) 610 (db:update-run-event_time db new-run-id) 598 (db:update-run-event_time db new-run-id) 611 ;; index the already saved tests by testname and itempath in curr-tests-hash | 599 ;; index the already saved tests by testname and itemdat in curr-tests-hash 612 (for-each 600 (for-each 613 (lambda (testdat) 601 (lambda (testdat) 614 (let* ((testname (db:test-get-testname testdat)) 602 (let* ((testname (db:test-get-testname testdat)) 615 (item-path (db:test-get-item-path testdat)) 603 (item-path (db:test-get-item-path testdat)) 616 (full-name (conc testname "/" item-path))) 604 (full-name (conc testname "/" item-path))) 617 (hash-table-set! curr-tests-hash full-name testdat))) 605 (hash-table-set! curr-tests-hash full-name testdat))) 618 curr-tests) 606 curr-tests)

Modified test_records.scm from [1c9875ade7275430] to [7236ce28391e9ea2].

1 ;; make-vector-record tests testqueue testname testconfig waitons priority items 1 ;; make-vector-record tests testqueue testname testconfig waitons priority items 2 (define (make-tests:testqueue)(make-vector 5)) | 2 (define (make-tests:testqueue)(make-vector 6 #f)) 3 (define-inline (tests:testqueue-get-testname vec) (vector-ref vec 0)) 3 (define-inline (tests:testqueue-get-testname vec) (vector-ref vec 0)) 4 (define-inline (tests:testqueue-get-testconfig vec) (vector-ref vec 1)) 4 (define-inline (tests:testqueue-get-testconfig vec) (vector-ref vec 1)) 5 (define-inline (tests:testqueue-get-waitons vec) (vector-ref vec 2)) 5 (define-inline (tests:testqueue-get-waitons vec) (vector-ref vec 2)) 6 (define-inline (tests:testqueue-get-priority vec) (vector-ref vec 3)) 6 (define-inline (tests:testqueue-get-priority vec) (vector-ref vec 3)) > 7 ;; items: #f=no items, list=list of items remaining, proc=need to call to get it 7 (define-inline (tests:testqueue-get-items vec) (vector-ref vec 4)) 8 (define-inline (tests:testqueue-get-items vec) (vector-ref vec 4)) > 9 (define-inline (tests:testqueue-get-itemdat vec) (vector-ref vec 5)) 8 10 9 (define-inline (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val) 11 (define-inline (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val) 10 (define-inline (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val) 12 (define-inline (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val) 11 (define-inline (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val) 13 (define-inline (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val) 12 (define-inline (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val) 14 (define-inline (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val) 13 (define-inline (tests:testqueue-set-items! vec val)(vector-set! vec 4 val) 15 (define-inline (tests:testqueue-set-items! vec val)(vector-set! vec 4 val) > 16 (define-inline (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val)