︙ | | |
24
25
26
27
28
29
30
31
32
33
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
|
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;; to extract info from the structure returned
;;
(define (runs:get-runs-by-patt db keys runnamepatt targpatt) ;; test-name)
(let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
(keystr (car tmp))
(header (cadr tmp))
(res '())
(key-patt "")
(runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
(qry-str #f)
(keyvals (keys:target->keyval keys targpatt)))
(for-each (lambda (keyval)
(let* ((key (car keyval))
(patt (cadr keyval))
(fulkey (conc ":" key))
(wildtype (if (substring-index "%" patt) "like" "glob")))
(if patt
(set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
(begin
(debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
(exit 6)))))
keyvals)
(set! qry-str (conc "SELECT " keystr " FROM runs WHERE runname " runwildtype " ? " key-patt ";"))
(debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
(sqlite3:for-each-row
(lambda (a . r)
(set! res (cons (list->vector (cons a r)) res)))
db
qry-str
runnamepatt)
(vector header res)))
(define (runs:test-get-full-path test)
(let* ((testname (db:test-get-testname test))
(itempath (db:test-get-item-path test)))
(conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
;; This is the *new* methodology. One record to inform them and in the chaos, organise them.
;;
|
︙ | | |
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
-
|
(for-each (lambda (varval)
(set! envdat (append envdat (list varval)))
(setenv (car varval)(cadr varval)))
(configf:get-section runconfig section)))
(list "default" target))
(vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id)))
(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
(let* ((target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
(get-environment-variable "MT_TARGET")))
(keys (if inkeys inkeys (cdb:remote-run db:get-keys #f)))
(keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
(vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)))
|
︙ | | |
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
-
+
|
;; Every time can-run-more-tests is called increment the delay
;;
;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine
;;
(define *last-num-running-tests* 0)
(define *runs:can-run-more-tests-count* 0)
(define (runs:shrink-can-run-more-tests-count db) ;; the db is just so we can use cdb:remote-run
(define (runs:shrink-can-run-more-tests-count db) ;; the db is a dummy var so we can use cdb:remote-run
(set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2)))
(define (runs:can-run-more-tests db jobgroup max-concurrent-jobs)
(thread-sleep! (cond
((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while
(else 0)))
(let* ((num-running (db:get-count-tests-running db))
|
︙ | | |
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
268
269
270
271
272
273
274
275
276
277
278
279
280
281
|
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
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
|
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
-
+
-
-
-
-
|
(>= num-running-in-jobgroup job-group-limit))
(debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup
" in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record))
#t)
(else #f))))
(list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)))))
;;======================================================================
;; New methodology. These routines will replace the above in time. For
;; now the code is duplicated. This stuff is initially used in the monitor
;; based code.
;;======================================================================
;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests.
;; keyvals.
;;
;; 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) ;; test-names
(common:clear-caches) ;; clear all caches
(let* ((db #f)
(keys (keys:config-get-fields *configdat*))
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
(run-id (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
;; keepgoing is the defacto modality now, will add hit-n-run a bit later
;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(runconfigf (conc *toppath* "/runconfigs.config"))
(required-tests '())
(test-records (make-hash-table))
(all-test-names (tests:get-valid-tests *toppath* "%"))) ;; we need a list of all valid tests to check waiton names
(set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars")
(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
;; look up all tests matching the comma separated list of globs in
;; test-patts (using % as wildcard)
(set! test-names (tests:get-valid-tests *toppath* test-patts))
(set! test-names (delete-duplicates test-names))
(set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts)))
(debug:print-info 0 "test names " test-names)
;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
;; -keepgoing is specified
(if (eq? *passnum* 0)
(begin
;; have to delete test records where NOT_STARTED since they can cause -keepgoing to
;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends
;; on test A but test B reached the point on being registered as NOT_STARTED and test
;; A failed for some reason then on re-run using -keepgoing the run can never complete.
(cdb:delete-tests-in-state *runremote* run-id "NOT_STARTED")
(cdb:remote-run db:set-tests-state-status #f run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
;; from here on out the db will be opened and closed on every call runs:run-tests-queue
;; (sqlite3:finalize! db)
;; now add non-directly referenced dependencies (i.e. waiton)
(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
(let* ((config (tests:get-testconfig hed '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 "\"")
(if db (sqlite3:finalize! db))
(exit 1)))))
(debug:print-info 8 "waitons string is " instr)
(let ((newwaitons
(string-split (cond
((procedure? instr)
(let ((res (instr)))
(debug:print-info 8 "waiton procedure results in string " res " for test " hed)
|
︙ | | |
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
|
693
694
695
696
697
698
699
700
701
702
703
704
705
706
|
-
-
-
|
(define (runs:queue-next-reg tal reg n regful)
(if regful
(cdr reg)
(if (eq? (length tal) 1)
'()
reg)))
(include "run-tests-queue-classic.scm")
(include "run-tests-queue-new.scm")
;; 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)
;; All these vars might be referenced by the testconfig file reader
(let* ((test-name (tests:testqueue-get-testname test-record))
(test-waitons (tests:testqueue-get-waitons test-record))
(test-conf (tests:testqueue-get-testconfig test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
|
︙ | | |
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
|
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
|
-
+
|
;;
;; NB// should pass in keys?
;;
(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f))
(common:clear-caches) ;; clear all caches
(let* ((db #f)
(keys (cdb:remote-run db:get-keys db))
(rundat (cdb:remote-run runs:get-runs-by-patt db keys runnamepatt target))
(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))))
(debug:print-info 4 "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
(if (> 2 (length state-status))
|
︙ | | |
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
|
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
|
-
+
|
;;======================================================================
;; Lock/unlock runs
;;======================================================================
(define (runs:handle-locking target keys runname lock unlock user)
(let* ((db #f)
(rundat (cdb:remote-run runs:get-runs-by-patt db keys runname target))
(rundat (mt:get-runs-by-patt keys runname target))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1)))
(for-each (lambda (run)
(let ((run-id (db:get-value-by-header run header "id")))
(if (or lock
(and unlock
(begin
|
︙ | | |