| ︙ | | |
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
-
-
-
+
+
+
+
+
-
+
-
-
+
+
|
(let* ((testname (db:test-get-testname test))
(itempath (db:test-get-item-path test)))
(conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
;;;;;; ;; This is the *new* methodology. One record to inform them and in the chaos, organise them.
;;;;;; ;;
;;;;;; (define (runs:create-run-record area-dat) ;; #!key (remote #f))
;;;;;; (let* ((remote (megatest:area-remote area-dat))
;;;;;; (mconfig (if *configdat*
;;;;;; *configdat*
;;;;;; (let* ((remote (megatest:area-remote area-dat))
;;;;;; (configdat (megatest:area-configdat area-dat))
;;;;;; (toppath (megatest:area-path area-dat)))
;;;;;; (mconfig (if configdat
;;;;;; configdat
;;;;;; (if (launch:setup-for-run)
;;;;;; *configdat*
;;;;;; configdat
;;;;;; (begin
;;;;;; (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting")
;;;;;; (exit 1)))))
;;;;;; (runrec (runs:runrec-make-record))
;;;;;; (target (common:args-get-target))
;;;;;; (runname (or (args:get-arg "-runname")
;;;;;; (args:get-arg ":runname")))
;;;;;; (testpatt (or (args:get-arg "-testpatt")
;;;;;; (args:get-arg "-runtests")))
;;;;;; (keys (keys:config-get-fields mconfig))
;;;;;; (keyvals (keys:target->keyval keys target))
;;;;;; (toppath *toppath*)
;;;;;; (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))
;;;;;; (set! runconfig (read-config (conc toppath "/runconfigs.config") #f #t sections: (list "default" target)))
;;;;;; (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f))
;;;;;; (begin
;;;;;; (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
;;;;;; (if db (sqlite3:finalize! db))
;;;;;; (exit 1)))
;;;;;; ;; Now have runconfigs data loaded, set environment vars
;;;;;; (for-each (lambda (section)
;;;;;; (for-each (lambda (varval)
;;;;;; (set! envdat (append envdat (list varval)))
;;;;;; (safe-setenv (car varval)(cadr varval)))
;;;;;; (configf:get-section runconfig section)))
;;;;;; (list "default" target))
;;;;;; (vector target runname testpatt keys keyvals envdat mconfig runconfig (common:get-remote remote run-id) transport db toppath run-id)))
(define (runs:set-megatest-env-vars run-id area-dat #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
(let* ((configdat (megatest:area-configdat area-dat))
(toppath (megatest:area-path area-dat))
(target (or (common:args-get-target)
(get-environment-variable "MT_TARGET")))
(keys (if inkeys inkeys (rmt:get-keys)))
(keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
(vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))
(link-tree (configf:lookup configdat "setup" "linktree")))
;; get the info from the db and put it in the cache
|
| ︙ | | |
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
-
+
|
(if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
(alist->env-vars (hash-table-ref/default configdat "env-override" '()))
;; Lets use this as an opportunity to put MT_RUNNAME in the environment
(let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
(if runname
(setenv "MT_RUNNAME" runname)
(debug:print 0 "ERROR: no value for runname for id " run-id)))
(setenv "MT_RUN_AREA_HOME" *toppath*)))
(setenv "MT_RUN_AREA_HOME" toppath)))
(define (set-item-env-vars itemdat)
(for-each (lambda (item)
(debug:print 2 "setenv " (car item) " " (cadr item))
(setenv (car item) (cadr item)))
itemdat))
|
| ︙ | | |
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
|
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
|
-
+
-
+
-
+
-
-
+
+
|
(all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names #f) ;; (hash-table-keys all-tests-registry))
(test-names #f) ;; (tests:filter-test-names all-test-names test-patts))
(required-tests #f) ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work
(task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id)))
(tdbdat (tasks:open-db)))
(if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
(if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10))
(set-signal-handler! signal/int
(lambda (signum)
(signal-mask! signum)
(print "Received signal " signum ", cleaning up before exit. Please wait...")
(let ((tdbdat (tasks:open-db)))
(rmt:tasks-set-state-given-param-key task-key "killed"))
(print "Killed by signal " signum ". Exiting")
(exit)))
;; register this run in monitor.db
(rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params)
(rmt:tasks-set-state-given-param-key task-key "running")
(runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
(runs:set-megatest-env-vars run-id area-dat inkeys: keys inrunname: runname) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
;; Now generate all the tests lists
(set! all-tests-registry (tests:get-all))
(set! all-tests-registry (tests:get-all area-dat))
(set! all-test-names (hash-table-keys all-tests-registry))
(set! test-names (tests:filter-test-names all-test-names test-patts))
(set! required-tests (lset-intersection equal? (string-split test-patts ",") test-names))
;; look up all tests matching the comma separated list of globs in
;; test-patts (using % as wildcard)
;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts)))
(debug:print-info 0 "tests search path: " (tests:get-tests-search-path configdat))
;; (set! test-names (delete-duplicates (tests:get-valid-tests toppath test-patts)))
(debug:print-info 0 "tests search path: " (tests:get-tests-search-path configdat area-dat))
(debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " "))
(debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " "))
;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
;; -keepgoing is specified
(if (eq? *passnum* 0)
(begin
|
| ︙ | | |
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
|
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
|
-
+
|
;;
;; What happended, this code is now duplicated in tests!?
;;
;;======================================================================
(if (not (null? test-names))
(let loop ((hed (car test-names))
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
(change-directory toppath) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
(setenv "MT_TEST_NAME" hed) ;;
(let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs))
(waitons (let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print 0 "ERROR: non-existent required test \"" hed "\"")
(exit 1)))))
|
| ︙ | | |
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
|
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
|
-
+
|
((or (null? prereqs-not-met)
(and (member 'toplevel testmode)
(null? non-completed)))
(debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))")
(let ((test-name (tests:testqueue-get-testname test-record)))
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" runname)
(runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
(runs:set-megatest-env-vars run-id area-dat inrunname: runname) ;; these may be needed by the launching process
(let ((items-list (items:get-items-from-config tconfig)))
(if (list? items-list)
(begin
(if (null? items-list)
(let ((test-id (rmt:get-test-id run-id test-name "")))
(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites"))))
(tests:testqueue-set-items! test-record items-list)
|
| ︙ | | |
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
|
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
|
-
+
|
;; we are going to reset all the counters for test retries by setting a new hash table
;; this means they will increment only when nothing can be run
(set! *max-tries-hash* (make-hash-table))
;; well, first lets see if cpu load throttling is enabled. If so wait around until the
;; average cpu load is under the threshold before continuing
(if (configf:lookup configdat "jobtools" "maxload") ;; only gate if maxload is specified
(common:wait-for-cpuload maxload numcpus waitdelay))
(run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
(run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry area-dat)
(hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
(if (or (not (null? tal))(not (null? reg)))
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
|
| ︙ | | |
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
|
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
|
-
+
|
(tfullname (db:test-make-full-name test-name item-path))
(newtal (append tal (list hed)))
(regfull (>= (length reg) reglen))
(num-running (rmt:get-count-tests-running-for-run-id run-id area-dat)))
;; every couple minutes verify the server is there for this run
(if (and (common:low-noise-print 60 "try start server" run-id)
(tasks:need-server run-id))
(tasks:need-server run-id area-dat))
(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood
(if (> num-running 0)
(set! last-time-some-running (current-seconds)))
(if (> (current-seconds)(+ last-time-some-running 240))
(hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
|
| ︙ | | |
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
|
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
|
-
+
+
-
+
-
+
|
(map (lambda (t)
(if (not (vector? t))
(conc t)
(conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t))))
lst))
;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry)
(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry area-dat)
;; All these vars might be referenced by the testconfig file reader
(let* ((toppath (megatest:area-path area-dat))
(let* ((test-name (tests:testqueue-get-testname test-record))
(test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
(test-path (hash-table-ref all-tests-registry test-name))
(force (hash-table-ref/default flags "-force" #f))
(rerun (hash-table-ref/default flags "-rerun" #f))
(keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(incomplete-timeout (string->number (or (configf:lookup configdat "setup" "incomplete-timeout") "x")))
(item-path "")
(db #f)
(full-test-name #f))
|
| ︙ | | |
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
|
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
|
-
-
+
+
|
"\n test-config: " (hash-table->alist test-conf)
"\n itemdat: " itemdat
)
(debug:print 2 "Attempting to launch test " full-test-name)
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_ITEMPATH" item-path)
(setenv "MT_RUNNAME" runname)
(runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
(change-directory *toppath*)
(runs:set-megatest-env-vars run-id area-dat inrunname: runname) ;; these may be needed by the launching process
(change-directory toppath)
;; Here is where the test_meta table is best updated
;; Yes, another use of a global for caching. Need a better way?
;;
;; There is now a single call to runs:update-all-test_meta and this
;; per-test call is not needed. Given the delicacy of the move to
;; v1.55 this code is being left in place for the time being.
|
| ︙ | | |
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
|
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
|
-
+
|
(if (not testdat) ;; should NOT happen
(debug:print 0 "ERROR: failed to get test record for test-id " test-id))
(set! test-id (db:test-get-id testdat))
(if (file-exists? test-path)
(change-directory test-path)
(begin
(debug:print "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?")
(change-directory *toppath*)))
(change-directory toppath)))
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
(if testdat
(string->symbol (test:get-state testdat))
'failed-to-insert))
((failed-to-insert)
(debug:print 0 "ERROR: Failed to insert the record into the db"))
|
| ︙ | | |
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
|
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
|
-
+
-
+
|
(lasttpath "/does/not/exist/I/hope")
(worker-thread #f))
(debug:print-info 4 "runs:operate-on run=" run ", header=" header)
(if (not (null? tests))
(begin
(case action
((remove-runs)
(if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
(if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10))
;; seek and kill in flight -runtests with % as testpatt here
(if (equal? testpatt "%")
(tasks:kill-runner target run-name)
(debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt))
(debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
((set-state-status)
(if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
(if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10))
(debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
((print-run)
(debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
action)
((run-wait)
(debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
((archive)
|
| ︙ | | |
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
|
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
|
-
+
|
(begin
(print "Updating " test-name " " fld " to " val)
(rmt:testmeta-update-field test-name fld val area-dat)))))
'(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))
;; Update test_meta for all tests
(define (runs:update-all-test_meta db)
(let ((test-names (tests:get-all))) ;; (tests:get-valid-tests)))
(let ((test-names (tests:get-all area-dat))) ;; (tests:get-valid-tests)))
(for-each
(lambda (test-name)
(let* ((test-conf (mt:lazy-read-test-config test-name)))
(if test-conf (runs:update-test_meta test-name test-conf))))
(hash-table-keys test-names))))
;; This could probably be refactored into one complex query ...
|
| ︙ | | |