Overview
Context
Changes
Modified Makefile
from [b20ff2bde7]
to [e33330dbf1].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
+
-
+
-
-
-
-
+
+
+
+
-
+
|
PREFIX=.
CSCOPTS=
SRCFILES = common.scm items.scm launch.scm \
ods.scm runconfig.scm server.scm configf.scm \
db.scm keys.scm margs.scm megatest-version.scm \
process.scm runs.scm tasks.scm tests.scm
GUISRCF = dashboard.scm dashboard-tests.scm dashboard-guimonitor.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
HELPERS=$(addprefix $(PREFIX)/bin/,mt_laststep mt_runstep mt_ezstep)
all : megatest dboard
megatest: $(OFILES) megatest.o
csc $(OFILES) megatest.o -o megatest
csc $(CSCOPTS) $(OFILES) megatest.o -o megatest
dboard : $(OFILES) $(GOFILES)
csc $(OFILES) $(GOFILES) -o dboard
# Special dependencies for the includes
db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o monitor.o dashboard.o megatest.o : db_records.scm
runs.o dashboard.o dashboard-tests.o : run_records.scm
keys.o db.o runs.o launch.o megatest.o : key_records.scm
tasks.o dashboard-tasks.o : task_records.scm
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o monitor.o dashboard.o megatest.o : db_records.scm
tests.o runs.o dashboard.o dashboard-tests.o : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : old-runs.scm test_records.scm
$(OFILES) $(GOFILES) : common_records.scm
%.o : %.scm
csc -c $<
csc $(CSCOPTS) -c $<
$(PREFIX)/bin/megatest : megatest
@echo Installing to PREFIX=$(PREFIX)
cp megatest $(PREFIX)/bin/megatest
$(HELPERS) : utils/mt_*
cp $< $@
|
︙ | | |
Modified db.scm
from [97aae994b9]
to [6268431c21].
︙ | | |
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
|
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
|
-
-
+
+
+
|
waiton)
(delete-duplicates result))))
;; the new prereqs calculation, looks also at itempath if specified
;; all prereqs must be met:
;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
(define (db:get-prereqs-not-met db run-id waiton ref-item-path)
(if (null? waiton)
(define (db:get-prereqs-not-met db run-id waitons ref-item-path)
(if (or (not waitons)
(null? waitons))
'()
(let* ((unmet-pre-reqs '())
(result '()))
(for-each
(lambda (waitontest-name)
;; by getting the tests with matching name we are looking only at the matching test
;; and related sub items
|
︙ | | |
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
|
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
|
-
+
-
+
-
+
|
(same-itempath (equal? ref-item-path item-path)))
(set! ever-seen #t)
(cond
;; case 1, non-item (parent test) is
((and (equal? item-path "") ;; this is the parent test
is-completed
is-ok)
(set! waiton-met #t))
(set! parent-waiton-met #t))
((and same-itempath
is-completed
is-ok)
(set! item-waiton-met #t)))))
tests)
(if (not (or waiton-met item-waiton-met))
(if (not (or parent-waiton-met item-waiton-met))
(set! result (cons waitontest-name result)))
;; if the test is not found then clearly the waiton is not met...
(if (not ever-seen)(set! result (cons waitontest-name result)))))
waiton)
waitons)
(delete-duplicates result))))
;;======================================================================
;; Extract ods file from the db
;;======================================================================
;; runspatt is a comma delimited list of run patterns
|
︙ | | |
Modified key_records.scm
from [46a3b150ea]
to [9216cfc587].
︙ | | |
17
18
19
20
21
22
23
24
25
|
17
18
19
20
21
22
23
24
25
26
27
|
+
-
+
+
|
(define-inline (keys->key/field keys . additional)
(string-join (map (lambda (k)(conc (key:get-fieldname k) " "
(key:get-fieldtype k)))
(append keys additional)) ","))
(define-inline (item-list->path itemdat)
(if (list? itemdat)
(string-intersperse (map cadr itemdat) "/"))
(string-intersperse (map cadr itemdat) "/")
""))
|
Modified megatest.scm
from [1013e8e76b]
to [0fa0f6c776].
︙ | | |
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
|
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
|
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; run all tests are are Not COMPLETED and PASS or CHECK
(if (args:get-arg "-runall")
(general-run-call
"-runall"
"run all tests"
(lambda (db keys keynames keyvallst)
(let* ((test-names (get-all-legal-tests))) ;; "PROD" is ignored for now
(debug:print 1 "INFO: Attempting to start the following tests...")
(debug:print 1 " " (string-intersperse test-names ","))
(run-tests db test-names)))))
(let* (;; (test-names (get-all-legal-tests))) ;; "PROD" is ignored for now
(runname (args:get-arg ":runname"))
(target (args:get-arg "-target")))
(if (not target)
(begin
(debug:print 0 "ERROR: -target is a required parameter")
(exit 0)))
(runs:run-tests db
target
runname
(args:get-arg "-testpatt")
(args:get-arg "-itempatt")
user
(make-hash-table))))))
;; (run-tests db test-names)))))
;;======================================================================
;; Rollup into a run
;;======================================================================
(if (args:get-arg "-rollup")
(general-run-call
"-rollup"
|
︙ | | |
Modified runs.scm
from [18ad85d758]
to [fd5fe59318].
︙ | | |
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
-
+
|
(lambda (patt)
(let ((tests (glob (conc *toppath* "/tests/" (string-translate patt "%" "*")))))
(set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
(set! test-names (append test-names
(map (lambda (testp)
(last (string-split testp "/")))
tests)))))
(string-split test-patts ","))
(if test-patts (string-split test-patts ",")(list "%")))
;; now remove duplicates
(set! test-names (delete-duplicates test-names))
(debug:print 0 "INFO: test names " test-names)
;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
|
︙ | | |
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
|
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
|
-
+
+
+
+
+
+
+
+
+
-
+
-
+
+
-
+
-
+
|
(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 (test:get-testconfig hed 'return-procs))
(waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))
(if w w "")))))
;; (items (items:get-items-from-config config)))
(if (not (hash-table-ref/default test-records hed #f))
(hash-table-set! test-records hed (vector hed config waitons (config-lookup config "requirements" "priority") #f)))
(hash-table-set! test-records
hed (vector hed ;; 0
config ;; 1
waitons ;; 2
(config-lookup config "requirements" "priority")
#f ;; 4
#f ;; 5
#f ;; spare
)))
(for-each
(lambda (waiton)
(if (and waiton (not (member waiton test-names)))
(begin
(set! required-tests (cons waiton required-tests))
(set! test-names (append test-names (list waiton))))))
waitons)
(let ((remtests (delete-duplicates (append waitons tal))))
(if (not (null? remtests))
(loop (car remtests)(cdr remtests)))))))
(if (not (null? required-tests))
(debug:print 1 "INFO: Adding " required-tests " to the run queue"))
;; NOTE: these are all parent tests, items are not expanded yet.
(runs:run-tests-queue test-records keyvallist)))
(runs:run-tests-queue db run-id runname test-records keyvallst flags)))
(define (runs:run-tests-queue test-records keyvallist)
(define (runs:run-tests-queue db run-id runname test-records keyvallst flags)
;; At this point the list of parent tests is expanded
;; NB// Should expand items here and then insert into the run queue.
(debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst)
(let ((sorted-testnames (tests:sort-by-priority-and-waiton test-records)))
(let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)))
(let loop (; (numtimes 0) ;; shouldn't need this
(hed (car sorted-test-names))
(tal (cdr sorted-test-names)))
(let* ((test-record (hash-table-ref test-records hed))
(tconfig (tests:testqueue-get-testconfig test-record))
(waitons (tests:testqueue-get-waitons test-record))
(priority (tests:testqueue-get-priority test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(items (tests:testqueue-get-items test-record))
(item-path (item-list->path itemdat)))
(debug:print 0 "WHERE TO DO: (items:get-items-from-config config)")
(cond
((not items) ;; when false the test is ok to be handed off to launch
(let ((have-resources (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running
(prereqs-not-met (db:get-prereqs-not-met db run-id waiton item-path)))
(prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path)))
(if (and have-resources
(null? prereqs-not-met))
;; no loop - drop though and use the loop at the bottom
(run:test db run-id runname keyvallst test-record flags)
;; else the run is stuck, temporarily or permanently
(let ((newtal (append tal (list hed))))
;; couldn't run, take a breather
|
︙ | | |
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
|
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
362
363
364
365
366
367
368
369
370
371
372
373
374
|
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
|
;; we get here on "drop through" - loop for next test in queue
(if (null? tal)
(debug:print 1 "INFO: All tests launched")
(loop (car tal)(cdr tal)))))))
(define (run:test db run-id runname keyvallst test-record flags)
(debug:print 1 "Launching test " test-name)
;; All these vars might be referenced by the testconfig file reader
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" runname)
(set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(change-directory *toppath*)
(let* ((test-name (tests:testqueue-get-testname test-record))
(test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
(test-conf (tests:testqueue-get-testconfig test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(force (hash-table-ref/default flags "-force" #f))
(rerun (hash-table-ref/default flags "-rerun" #f))
(keepgoing (hash-table-ref/default flags "-keepgoing" #f)))
(debug:print 1 "Launching test " test-name)
(debug:print 5
"test-config: " (hash-table->alist test-conf)
"\n itemdat: " itemdat
)
;; setting itemdat to a list if it is #f
(if (not itemdat)(set! itemdat '()))
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" runname)
(set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(change-directory *toppath*)
;; Here is where the test_meta table is best updated
(runs:update-test_meta db test-name test-conf)
;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
(let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
(new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
(new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
(testdat #f)
(test-info (db:get-test-info db run-id test-name item-path)))
(if (not test-info)(register-test db run-id test-name item-path))
(change-directory test-path)
(debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat))
(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"))
|
︙ | | |
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
|
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
|
-
+
|
(set! runflag #t))
(else (set! runflag #f)))
(debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
(if (not runflag)
(if (not parent-test)
(debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override"))
(let* ((get-prereqs-cmd (lambda ()
(db-get-prereqs-not-met db run-id waiton))) ;; check before running ....
(db-get-prereqs-not-met db run-id waitons))) ;; check before running ....
(launch-cmd (lambda ()
(launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags)))
(testrundat (list get-prereqs-cmd launch-cmd)))
(if (or force
(let ((preqs-not-yet-met ((car testrundat))))
(debug:print 2 "Preqrequesites for " test-name ": " preqs-not-yet-met)
(null? preqs-not-yet-met))) ;; are there any tests that must be run before this one...
|
︙ | | |
565
566
567
568
569
570
571
572
573
574
575
576
577
578
|
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
|
+
|
(set! currrecord (make-vector 10 #f))
(db:testmeta-add-record db test-name)))
(for-each
(lambda (key)
(let* ((idx (cadr key))
(fld (car key))
(val (config-lookup test-conf "test_meta" fld)))
;; (debug:print 5 "idx: " idx " fld: " fld " val: " val)
(if (and val (not (equal? (vector-ref currrecord idx) val)))
(begin
(print "Updating " test-name " " fld " to " val)
(db:testmeta-update-field db test-name fld val)))))
'(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)))))
;; Update test_meta for all tests
|
︙ | | |
Modified tests.scm
from [b7feda25e5]
to [42fb9b9880].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
+
|
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
(import (prefix sqlite3 sqlite3:))
(declare (unit tests))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(define (register-test db run-id test-name item-path)
(let ((item-paths (if (equal? item-path "")
(list item-path)
(list item-path ""))))
(for-each
|
︙ | | |
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
|
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
362
363
364
365
366
367
368
|
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
+
|
0))))
(sort
(hash-table-keys test-records) ;; avoid dealing with deleted tests, look at the hash table
(lambda (a b)
(let* ((a-record (hash-table-ref test-records a))
(b-record (hash-table-ref test-records b))
(a-waitons (tests:testqueue-get-waitons a-record))
(b-waitons (tests:testqueue-get-waitons a-record))
(a-priority (mungepriority (config-lookup tconf-a "requirements" "priority")))
(b-priority (mungepriority (config-lookup tconf-b "requirements" "priority"))))
(b-waitons (tests:testqueue-get-waitons b-record))
(a-config (tests:testqueue-get-testconfig a-record))
(b-config (tests:testqueue-get-testconfig b-record))
(a-raw-pri (config-lookup a-config "requirements" "priority"))
(b-raw-pri (config-lookup b-config "requirements" "priority"))
(a-priority (mungepriority a-raw-pri))
(b-priority (mungepriority b-raw-pri)))
;; (debug:print 5 "sort-by-priority-and-waiton, a: " a " b: " b
;; "\n a-record: " a-record
;; "\n b-record: " b-record
;; "\n a-waitons: " a-waitons
;; "\n b-waitons: " b-waitons
;; "\n a-config: " (hash-table->alist a-config)
;; "\n b-config: " (hash-table->alist b-config)
;; "\n a-raw-pri: " a-raw-pri
;; "\n b-raw-pri: " b-raw-pri
;; "\n a-priority: " a-priority
;; "\n b-priority: " b-priority)
(tests:testqueue-set-priority! a-record a-priority)
(tests:testqueue-set-priority! b-record b-priority)
(if (and a-waiton (member? (tests:testqueue-get-testname b) a-waitons))
(if (and a-waitons (member (tests:testqueue-get-testname b-record) a-waitons))
#f ;; cannot have a which is waiting on b happening before b
(if (and b-waiton (member? (tests:testqueue-get-testname a) b-waitons))
(if (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons))
#t ;; this is the correct order, b is waiting on a and b is before a
(if (> a-priority b-priority)
#t ;; if a is a higher priority than b then we are good to go
#f))))))))
;;======================================================================
|
︙ | | |