| ︙ | | |
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
|
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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
|
hed tal reg reruns test-record
test-name item-path jobgroup
waitons testmode newtal itemmaps prereqs-not-met)
;; set up needed environment variables given a run-id and optionally a target, itempath etc.
;;
(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f))
;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
(let* ((target (or intarget
(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")))
(link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
(if testname (setenv "MT_TEST_NAME" testname))
(if itempath (setenv "MT_ITEMPATH" itempath))
;; get the info from the db and put it in the cache
(if link-tree
(setenv "MT_LINKTREE" link-tree)
(debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section."))
(if (not vals)
(let ((ht (make-hash-table)))
(hash-table-set! *env-vars-by-run-id* run-id ht)
(set! vals ht)
(for-each
(lambda (key)
(hash-table-set! vals (car key) (cadr key)))
keyvals)))
;; from the cached data set the vars
(hash-table-for-each
vals
(lambda (key val)
(debug:print 2 *default-log-port* "setenv " key " " val)
(safe-setenv key val)))
;;(bb-check-path msg: "runs:set-megatest-env-vars block 1")
;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals))
(if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
;; we had a case where there was an exception generated by the hash-table-ref
;; due to *configdat* being #f Adding a handle and exit
(let fatal-loop ((count 0))
(handle-exceptions
exn
(let ((call-chain (get-call-chain))
(msg ((condition-property-accessor 'exn 'message) exn)))
(if (< count 5)
(begin ;; this call is colliding, do some crude stuff to fix it.
(debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count)
(launch:setup force-reread: #t)
(fatal-loop (+ count 1)))
(begin
(debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count " times. Message: " msg)
(debug:print 0 *default-log-port* "Call chain:")
(with-output-to-port *default-log-port*
(lambda ()
(print "*configdat* is >>"*configdat*"<<")
(pp *configdat*)
(pp call-chain)))
(exit 1))))
;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5")
(when (or (not *configdat*) (not (hash-table? *configdat*)))
(debug:print 0 *default-log-port* "WARNING: *configdat* was inaccessible! This should never happen. Brute force reread.")
;;(BB> "ERROR: *configdat* was inaccessible! This should never happen. Brute force reread.")
(thread-sleep! 2) ;; assuming nfs lag.
(launch:setup force-reread: #t))
(alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))
(alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block.
;;(bb-check-path msg: "runs:set-megatest-env-vars block 2")
;; 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-error 0 *default-log-port* "no value for runname for id " run-id)))
(setenv "MT_RUN_AREA_HOME" *toppath*)
;; if a testname and itempath are available set the remaining appropriate variables
(if testname (setenv "MT_TEST_NAME" testname))
(if itempath (setenv "MT_ITEMPATH" itempath))
;;(bb-check-path msg: "runs:set-megatest-env-vars block 3")
(if (and testname link-tree)
(setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/"
(getenv "MT_TARGET") "/"
(getenv "MT_RUNNAME") "/"
(getenv "MT_TEST_NAME")
(if (and itempath
(not (equal? itempath "")))
|
| ︙ | | |
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
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
264
265
266
267
|
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
-
+
+
+
+
+
+
-
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
|
(if (runs:lownoise (conc "maxjobgroup " jobgroup) 60)
(debug:print 1 *default-log-port* "WARNING: number of jobs " num-running-in-jobgroup
" in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit))
#t)
(else #f))))
(list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)))))
(define (runs:run-pre-hook run-id)
(let* ((run-pre-hook (configf:lookup *configdat* "runs" "pre-hook"))
(existing-tests (if run-pre-hook
(rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
#f #f ;; offset limit
#f ;; not-in
#f ;; sort-by
#f ;; sort-order
#f ;; get full data (not 'shortlist)
0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
'dashboard)
'()))
(log-dir (conc *toppath* "/logs"))
(log-file (conc "pre-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
(full-log-fname (conc log-dir "/" log-file)))
(if run-pre-hook
(if (null? existing-tests)
(let* ((use-log-dir (if (not (directory-exists? log-dir))
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir)
#f)
(create-directory log-dir #t)
#t)
#t))
(start-time (current-seconds))
(actual-logf (if use-log-dir full-log-fname log-file)))
(handle-exceptions
exn
(begin
(print-call-chain *default-log-port*)
(debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 0 *default-log-port* "ERROR: failed to run pre-hook " run-pre-hook ", check the log " log-file))
(debug:print-info 0 *default-log-port* "running run-pre-hook: \"" run-pre-hook "\", log is " actual-logf)
(system (conc run-pre-hook " >> " actual-logf " 2>&1"))
(debug:print-info 0 *default-log-port* "pre-hook \"" run-pre-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))
(debug:print 0 *default-log-port* "Skipping pre-hook call \"" run-pre-hook "\" as there are existing tests for this run.")))))
;; test-names: Comma separated patterns same as test-patts but used in selection
;; of tests to run. The item portions are not respected.
;; FIXME: error out if /patt specified
;;
(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
(run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name)))
;; (deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
(dbfile (conc *toppath* "/megatest.db"))
(readonly-mode (not (file-write-access? dbfile)))
(test-records (make-hash-table))
;; need to process runconfigs before generating these lists
(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) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts))
(required-tests #f) ;; Put fully qualified test/testpath names in this list to be done
(task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id)))
(tdbdat (tasks:open-db))
;; (tdbdat (tasks:open-db))
(config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
(if x (string->number x) #f)))
(allowed-tests #f))
;; check if readonly
(when readonly-mode
(debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed.")
(exit 1))
;; per user request. If less than 100Meg space on dbdir partition, bail out with error
;; this will reduce issues in database corruption
(common:check-db-dir-and-exit-if-insufficient)
(let ((tdbdat (tasks:open-db)))
(rmt:tasks-set-state-given-param-key task-key "killed"))
;; (let ((tdbdat (tasks:open-db)))
(rmt:tasks-set-state-given-param-key task-key "killed") ;; )
(print "Killed by signal " signum ". Exiting")
(thread-sleep! 3)
(exit))))
(th2 (make-thread (lambda ()
(thread-sleep! 5)
(debug:print 0 *default-log-port* "Done")
(exit 4)))))
(thread-start! th2)
(thread-start! th1)
(thread-join! th2)))))
(set-signal-handler! signal/int sighand)
(set-signal-handler! signal/term sighand))
;; force the starting of a server
(debug:print 0 *default-log-port* "waiting on server...")
(server:start-and-wait *toppath*)
(runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
(set! runconf (if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
(begin
(debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf)
#f)))
(if (not test-patts) ;; first time in - adjust testpatt
(set! test-patts (common:args-get-testpatt runconf)))
;; if test-patts is #f at this point there is something wrong and we need to bail out
(if (not test-patts)
(begin
(debug:print 0 *default-log-port* "WARNING: there is no test pattern for this run. Exiting now.")
(exit 0)))
(if (args:get-arg "-tagexpr")
(begin
(set! allowed-tests (string-join (runs:get-tests-matching-tags (args:get-arg "-tagexpr")) ","))) ;; tests will be ANDed with this list
(set! allowed-tests (string-join (runs:get-tests-matching-tags (args:get-arg "-tagexpr")) ","))
(debug:print-info 0 *default-log-port* "filtering initial test list with tagexpr: " (args:get-arg "-tagexpr") " => " allowed-tests)
));; tests will be ANDed with this list
;; 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")
;; Now generate all the tests lists
(set! all-tests-registry (tests:get-all)) ;; hash of testname => path-to-test
|
| ︙ | | |
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
|
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
|
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
|
;; on test A but test B reached the point on being registered as NOT_STARTED and test
;; A failed for some reason then on re-run using -keepgoing the run can never complete.
;;
;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED")
;; Now convert anything in allow-auto-rerun to NOT_STARTED
;;
(for-each (lambda (state)
(rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state))
(string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") "")))))
(for-each
(lambda (state-status)
(let* ((ss-lst (string-split-fields "/" state-status #:infix))
(state (if (> (length ss-lst) 0)(car ss-lst) #f))
(status (if (> (length ss-lst) 1)(cadr ss-lst) #f)))
(rmt:set-tests-state-status run-id test-names state status "NOT_STARTED" status)))
;; list of state/status pairs separated by spaces
(string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") "")))))
;; Ensure all tests are registered in the test_meta table
(runs:update-all-test_meta #f)
;; run the run prehook if there are no tests yet run for this run:
;;
(runs:run-pre-hook run-id)
;; now add non-directly referenced dependencies (i.e. waiton)
;;======================================================================
;; refactoring this block into tests:get-full-data
;;
;; What happended, this code is now duplicated in tests!?
;;
;;======================================================================
|
| ︙ | | |
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
|
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
|
-
+
|
(cons hed reruns)))
#f)) ;; #f flags do not loop
((and (not (null? fails))(member 'toplevel testmode))
(if (or (not (null? reg))(not (null? tal)))
(list (car newtal)(append (cdr newtal) reg) '() reruns)
#f))
((null? runnables) #f) ;; if we get here and non-completed is null the it's all over.
((null? runnables) #f) ;; if we get here and non-completed is null then it is all over.
(else
(debug:print 0 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now")
;; (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)
;; reruns)
(list (car newtal)(cdr newtal) reg reruns)))))
|
| ︙ | | |
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
|
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
|
-
+
+
|
(list (car newtal)(cdr newtal) reg reruns))
;; This is the final stage, everything is in place so launch the test
;;
((and have-resources
(or (null? prereqs-not-met)
(and (member 'toplevel testmode) ;; 'toplevel)
(null? non-completed))))
(null? non-completed)
(not (member 'exclusive testmode)))))
;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path))
;; 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
|
| ︙ | | |
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
|
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
|
-
+
-
-
-
-
+
-
+
|
(let* ((run-info (rmt:get-run-info run-id))
(tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path"))
(sorted-test-names (tests:sort-by-priority-and-waiton test-records))
(test-registry (make-hash-table))
(registry-mutex (make-mutex))
(num-retries 0)
(max-retries (config-lookup *configdat* "setup" "maxretries"))
(max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs")))
(max-concurrent-jobs (configf:lookup-number *configdat* "setup" "max_concurrent_jobs" default: 50))
(if (and mcj (string->number mcj))
(string->number mcj)
1))) ;; length of the register queue ahead
(reglen (if (number? reglen-in) reglen-in 1))
(tdbdat (tasks:open-db))
;; (tdbdat (tasks:open-db))
(runsdat (make-runs:dat
;; hed: hed
;; tal: tal
;; reg: reg
;; reruns: reruns
reglen: reglen
regfull: #f ;; regfull
|
| ︙ | | |
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
|
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
|
+
-
-
-
-
+
+
+
+
|
waitons: waitons
testmode: testmode
newtal: newtal
itemmaps: itemmaps
;; prereqs-not-met: prereqs-not-met
)))
(runs:dat-regfull-set! runsdat regfull)
;; 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:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood
;; every 15 minutes verify the server is there for this run
(if (and (common:low-noise-print 240 "try start server" run-id)
(not (server:check-if-running *toppath*)))
(server:kind-run *toppath*))
(if (> num-running 0)
(set! last-time-some-running (current-seconds)))
(if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000)))
(hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
;; (debug:print 0 *default-log-port* "max-tries-hash: " (hash-table->alist *max-tries-hash*))
|
| ︙ | | |
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
|
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
|
-
+
|
(debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns))
)))
;; now *if* -run-wait we wait for all tests to be done
;; Now wait for any RUNNING tests to complete (if in run-wait mode)
(thread-sleep! 5) ;; I think there is a race condition here. Let states/statuses settle
(let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id))
(prev-num-running 0))
;; (BB> "num-running=" num-running ", prev-num-running=" prev-num-running)
;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running)
(if (and (or (args:get-arg "-run-wait")
(equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
(> num-running 0))
(begin
;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0))
(if (> (current-seconds)(+ last-time-incomplete 900))
|
| ︙ | | |
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
|
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
|
-
+
+
|
(define (runs:calc-runnable prereqs-not-met)
(filter
(lambda (t)
(or (not (vector? t))
(and (equal? "NOT_STARTED" (db:test-get-state t))
(member (db:test-get-status t)
'("n/a" "KEEP_TRYING")))))
|
| ︙ | | |
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
|
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
|
-
+
-
|
(configf:lookup test-conf "skip" "prevrunning"))
;; run-ids = #f means *all* runs
(let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)))
(if (not (null? running-tests)) ;; have to skip
(set! skip-test "Skipping due to previous tests running"))))
((and skip-check
(configf:lookup test-conf "skip" "fileexists"))
(if (file-exists? (configf:lookup test-conf "skip" "fileexists"))
(if (common:file-exists? (configf:lookup test-conf "skip" "fileexists"))
(set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))
|
| ︙ | | |
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
|
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
|
-
+
+
+
+
+
+
+
+
+
+
|
;; 'set-state-status
;;
;; NB// should pass in keys?
;;
(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '()))
(common:clear-caches) ;; clear all caches
(let* ((db #f)
(tdbdat (tasks:open-db))
;; (tdbdat (tasks:open-db))
(keys (rmt:get-keys))
(rundat (mt:get-runs-by-patt keys runnamepatt target))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1))
(states (if state (string-split state ",") '()))
(statuses (if status (string-split status ",") '()))
(state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))
(rp-mutex (make-mutex))
(bup-mutex (make-mutex)))
(let* ((write-access-actions '(remove-runs set-state-status archive run-wait))
(dbfile (conc *toppath* "/megatest.db"))
(readonly-mode (not (file-write-access? dbfile))))
(when (and readonly-mode
(member action write-access-actions))
(debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .")
(exit 1)))
(debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
(if (> 2 (length state-status))
(begin
(debug:print-error 0 *default-log-port* "the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL")
(exit)))
(for-each
(lambda (run)
|
| ︙ | | |
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
|
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
|
-
+
|
;; seek and kill in flight -runtests with % as testpatt here
;; (if (equal? testpatt "%")
(tasks:kill-runner target run-name testpatt)
;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt))
(debug:print 1 *default-log-port* "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)(tasks:start-and-wait-for-server tdbdat run-id 10))
(debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
((print-run)
(debug:print 1 *default-log-port* "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
action)
((run-wait)
(debug:print 1 *default-log-port* "Waiting for run " runkey ", run=" runnamepatt " to complete"))
((archive)
|
| ︙ | | |
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
|
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
|
+
+
|
(if (launch:setup)
(begin
(full-runconfigs-read) ;; cache the run config
(launch:cache-config)) ;; do not cache here - need to be sure runconfigs is processed
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(set! keys (keys:config-get-fields *configdat*))
;; have enough to process -target or -reqtarg here
(if (args:get-arg "-reqtarg")
(let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL
(runconfig (read-config runconfigf #f #t environ-patt: #f)))
(if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
(keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
|
| ︙ | | |
2047
2048
2049
2050
2051
2052
2053
|
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) "
"SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;")
(db:test-get-id testdat))))
))
prev-tests)))
;; clean cache files
(define (runs:clean-cache target runname toppath)
(if target
(if runname
(let* ((linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree")))
(runtop (conc linktree "/" target "/" runname))
(files (if (file-exists? runtop)
(append (glob (conc runtop "/.megatest*"))
(glob (conc runtop "/.runconfig*")))
'())))
(if (null? files)
(debug:print-info 0 *default-log-port* "No cached megatest or runconfigs files found. None removed.")
(begin
(debug:print-info 0 *default-log-port* "Removing cached files:\n " (string-intersperse files "\n "))
(for-each
(lambda (f)
(handle-exceptions
exn
(debug:print 0 *default-log-port* "WARNING: Failed to remove file " f)
(delete-file f)))
files))))
(debug:print-error 0 *default-log-port* "-clean-cache requires -runname."))
(debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg")))
|