Overview
Context
Changes
Modified Makefile
from [1d989205bc]
to [0976c16632].
︙ | | |
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
+
+
+
+
+
+
+
|
$(PREFIX)/bin/.$(ARCHSTR) :
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
test: tests/tests.scm
cd tests;csi -I .. -b -n tests.scm
ext-tests/.fslckout : $(MTQA_FOSSIL)
mkdir -p ext-tests
cd ext-tests;fossil open --nested $(MTQA_FOSSIL)
$(MTQA_FOSSIL) :
fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)
clean :
rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o
# Deploy section (not complete yet)
#
$(DEPLOYHELPERS) : utils/mt_*
$(INSTALL) $< $@
|
︙ | | |
Modified common.scm
from [ed7431fe23]
to [9eb6e93365].
︙ | | |
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
|
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
|
-
+
|
best
#f))) ;; #f means no disk candidate found
;;======================================================================
;; E N V I R O N M E N T V A R S
;;======================================================================
(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF")))
(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES")))
(let ((envvars (get-environment-variables))
(whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")))
(with-output-to-file (conc fname ".csh")
(lambda ()
(for-each (lambda (keyval)
(let* ((key (car keyval))
(val (cdr keyval))
|
︙ | | |
709
710
711
712
713
714
715
716
717
718
719
720
721
722
|
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(set! res (cons (list var prv) res))
(if val
(setenv var (->string val))
(unsetenv var))))
lst)
res)
'()))
;; clear vars matching pattern, run proc, set vars back
;; if proc is a string run that string as a command with
;; system.
;;
(define (common:without-vars proc . var-patts)
(let ((vars (make-hash-table)))
(for-each
(lambda (vardat) ;; each env var
(for-each
(lambda (var-patt)
(if (string-match var-patt (car vardat))
(let ((var (car vardat))
(val (cdr vardat)))
(hash-table-set! vars var val)
(unsetenv var))))
var-patts))
(get-environment-variables))
(cond
((string? proc)(system proc))
(proc (proc)))
(hash-table-for-each
vars
(lambda (var val)
(setenv var val)))
vars))
;;======================================================================
;; time and date nice to have stuff
;;======================================================================
(define (seconds->hr-min-sec secs)
(let* ((hrs (quotient secs 3600))
|
︙ | | |
Modified dashboard-tests.scm
from [9666ae3621]
to [c3aeea831f].
︙ | | |
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
|
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
|
+
-
-
+
+
+
|
(dashboard-tests:run-html-viewer lfilename)
(message-window (conc "File " lfilename " not found"))))))
(xterm (lambda (x)
(if (directory-exists? rundir)
(let ((shell (if (get-environment-variable "SHELL")
(conc "-e " (get-environment-variable "SHELL"))
"")))
(common:without-vars
(system (conc "cd " rundir
";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
(conc "cd " rundir
";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")
"MT_.*"))
(message-window (conc "Directory " rundir " not found")))))
(widgets (make-hash-table))
(refreshdat (lambda ()
(let* ((curr-mod-time (file-modification-time db-path))
;; (max ..... (if (file-exists? testdat-path)
;; (file-modification-time testdat-path)
;; (begin
|
︙ | | |
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
|
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
|
-
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(begin
;(mutex-lock! mx1)
(iup:attribute-set! lbl "TITLE" newval)
;(mutex-unlock! mx1)
)))))
lbl))
(store-button store-label)
(command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10"))
(command-launch-button (iup:button "Execute!" #:action (lambda (x)
(command-proc (lambda (command-text-box)
(let* ((cmd (iup:attribute command-text-box "VALUE"))
(fullcmd (conc (dtests:get-pre-command)
cmd
(dtests:get-post-command))))
(debug:print-info 02 "Running command: " fullcmd)
(system fullcmd)))))
(common:without-vars fullcmd "MT_.*"))))
(command-text-box (iup:textbox
#:expand "HORIZONTAL"
#:font "Courier New, -10"
#:action (lambda (obj cnum val)
;; (print "cnum=" cnum)
(if (eq? cnum 13)
(command-prox obj)))
))
(command-launch-button (iup:button "Execute!" #:action (lambda (x)
(command-proc command-text-box))))
;; (lambda (x)
;; (let* ((cmd (iup:attribute command-text-box "VALUE"))
;; (fullcmd (conc (dtests:get-pre-command)
;; cmd
;; (dtests:get-post-command))))
;; (debug:print-info 02 "Running command: " fullcmd)
;; (common:without-vars fullcmd "MT_.*")))))
(kill-jobs (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "megatest -target " keystring " -runname " runname
" -set-state-status KILLREQ,n/a -testpatt %/% "
" -state RUNNING"))))
(run-test (lambda (x)
|
︙ | | |
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
|
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
|
-
+
-
+
+
-
+
-
+
+
|
command-text-box "VALUE"
(conc "megatest -remove-runs -target " keystring " -runname " runname
" -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
" -v"))))
(clean-run-execute (lambda (x)
(let ((cmd (conc "bmegatest -remove-runs -target " keystring " -runname " runname
(let ((cmd (conc "megatest -remove-runs -target " keystring " -runname " runname
" -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
";megatest -target " keystring " -runname " runname
" -runtests " (conc testname "/" (if (equal? item-path "")
" -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
)))
(common:without-vars
(system (conc (dtests:get-pre-command)
(conc (dtests:get-pre-command)
cmd
(dtests:get-post-command))))))
(dtests:get-post-command))
"MT_.*"))))
(remove-test (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "megatest -remove-runs -target " keystring " -runname " runname
" -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
|
︙ | | |
Modified db.scm
from [5bb794bf74]
to [eb4ce6c48f].
︙ | | |
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
|
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
|
+
+
-
+
-
-
+
-
-
-
-
+
+
+
+
|
;;======================================================================
;; M I S C M A N A G E M E N T I T E M S
;;======================================================================
;; A routine to map itempaths using a itemmap
;; patha and pathb must be strings or this will fail
;;
;; path-b is waiting on path-a
;;
(define (db:compare-itempaths patha pathb itemmaps)
(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
(debug:print-info 6 "ITEMMAPS: " itemmaps)
(let* ((testname-a (car (string-split patha "/")))
(itemmap (tests:lookup-itemmap itemmaps testname-a)))
(let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name)))
(if itemmap
(let ((pathb-mapped (db:multi-pattern-apply pathb itemmap)))
(debug:print-info 6 "ITEMMAP is " itemmap ", path: " pathb ", mapped path: " pathb-mapped)
(equal? patha pathb-mapped))
(equal? patha pathb))))
(let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
(debug:print-info 6 "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
(equal? path-a path-b-mapped))
(equal? path-b path-a))))
;; A routine to convert test/itempath using a itemmap
;; NOTE: to process only an itempath (i.e. no prepended testname)
;; just call db:multi-pattern-apply
;;
(define (db:convert-test-itempath path-in itemmap)
(debug:print-info 6 "ITEMMAP is " itemmap)
|
︙ | | |
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
|
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
|
-
+
|
;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
;;
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;; mode 'toplevel means that tests must be COMPLETED only
;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;;
;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f))
(define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f))
(if (or (not waitons)
(null? waitons))
'()
(let* ((unmet-pre-reqs '())
(result '()))
(for-each
(lambda (waitontest-name)
|
︙ | | |
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
|
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
|
+
-
+
|
(let* ((state (db:test-get-state test))
(status (db:test-get-status test))
(item-path (db:test-get-item-path test))
(is-completed (equal? state "COMPLETED"))
(is-running (equal? state "RUNNING"))
(is-killed (equal? state "KILLED"))
(is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))
;; testname-b path-a path-b
(same-itempath (db:compare-itempaths item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path)))
(same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (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 of the waiton being examined
is-completed
(or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait))))))
(set! parent-waiton-met #t))
|
︙ | | |
Modified docs/manual/megatest_manual.html
from [56893fab94]
to [0577937b3e].
︙ | | |
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
|
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
|
-
-
+
+
-
-
-
+
+
-
-
-
+
+
-
-
-
+
-
-
-
-
+
-
+
-
+
+
-
-
+
+
+
+
-
+
-
-
-
-
-
+
+
-
-
+
-
-
-
-
-
-
+
+
+
+
+
+
-
-
+
-
+
+
+
+
-
+
-
+
-
-
-
-
-
-
+
-
-
-
+
+
-
-
+
-
-
-
-
+
+
+
+
+
+
+
|
<div class="title">Testconfig for Test C</div>
<div class="content monospaced">
<pre>[requirements]
waiton A B
[itemmap]
A (\d+)/aa aa/\1
B (\d+)/bb bb/\1</pre>
</div></div>
B (\d+)/bb --------------------
<div class="listingblock">
<div class="title">Testconfig for Test D</div>
<div class="content monospaced">
.Testconfig for Test D</pre>
</div></div>
<pre>[requirements]
waiton C
itemmap (\d+)/res \1/aa</pre>
<div class="paragraph"><p>waiton C
itemmap (\d+)/res \1/aa</p></div>
</div></div>
<div class="listingblock">
<div class="title">Testconfig for Test E</div>
<div class="content monospaced">
<pre>[requirements]
<pre>.Testconfig for Test E</pre>
waiton C
itemmap (\d+)/res \1/bb</pre>
</div></div>
</div>
<div class="sect3">
<div class="paragraph"><p>waiton C
<h4 id="_dynamic_flow_dependency_tree">Dynamic Flow Dependency Tree</h4>
itemmap (\d+)/res \1/bb</p></div>
<div class="listingblock">
<div class="title">Autogeneration waiton list for dynamic flow dependency trees</div>
<div class="content monospaced">
<pre>Dynamic Flow Dependency Tree
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
<pre>[requirements]
# With a toplevel test you may wish to generate your list
.Autogeneration waiton list for dynamic flow dependency trees</pre>
</div></div>
<div class="paragraph"><p># With a toplevel test you may wish to generate your list
# of tests to run dynamically
#
# waiton #{shell get-valid-tests-to-run.sh}</pre>
waiton #{shell get-valid-tests-to-run.sh}</p></div>
</div></div>
</div>
<div class="sect3">
<h4 id="_run_time_limit_2">Run time limit</h4>
<div class="listingblock">
<div class="content monospaced">
<pre>runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s</pre>
<pre>Run time limit
^^^^^^^^^^^^^^</pre>
</div></div>
</div>
<div class="sect3">
<div class="paragraph"><p>runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s</p></div>
<h4 id="_skip">Skip</h4>
<div class="paragraph"><p>A test with a skip section will conditional skip running.</p></div>
<div class="listingblock">
<div class="title">Skip section example</div>
<div class="content monospaced">
<pre>[skip]
prevrunning x
# rundelay 30m 15s</pre>
<pre>Skip
^^^^
A test with a skip section will conditional skip running.
.Skip section example</pre>
</div></div>
</div>
<div class="sect3">
<div class="paragraph"><p>prevrunning x
<h4 id="_skip_on_still_running_tests">Skip on Still-running Tests</h4>
# rundelay 30m 15s</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>Skip on Still-running Tests
^^^^^^^^^^^^^^^^^^^^^^^^^^^</pre>
</div></div>
<pre># NB// If the prevrunning line exists with *any* value the test will
<div class="paragraph"><p># NB// If the prevrunning line exists with <strong>any</strong> value the test will
# automatically SKIP if the same-named test is currently RUNNING. The
# "x" can be any string. Comment out the prevrunning line to turn off
# skip.
# skip.</p></div>
[skip]
prevrunning x</pre>
</div></div>
</div>
<div class="sect3">
<div class="paragraph"><p>prevrunning x</p></div>
<h4 id="_skip_if_a_file_exists">Skip if a File Exists</h4>
<div class="listingblock">
<div class="content monospaced">
<pre>[skip]
fileexists /path/to/a/file # skip if /path/to/a/file exists</pre>
<pre>Skip if a File Exists
^^^^^^^^^^^^^^^^^^^^^</pre>
</div></div>
</div>
<div class="sect3">
<div class="paragraph"><p>fileexists /path/to/a/file # skip if /path/to/a/file exists</p></div>
<h4 id="_skip_if_test_ran_more_recently_than_specified_time">Skip if test ran more recently than specified time</h4>
<div class="listingblock">
<div class="title">Skip if this test has been run in the past fifteen minutes and 15 seconds.</div>
<div class="content monospaced">
<pre>[skip]
rundelay 15m 15s</pre>
<pre>Skip if test ran more recently than specified time
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
.Skip if this test has been run in the past fifteen minutes and 15 seconds.</pre>
</div></div>
</div>
</div>
</div>
</div>
<div class="sect3">
<h4 id="_disks">Disks</h4>
<div class="paragraph"><p>A disks section in testconfig will override the disks section in
megatest.config. This can be used to allocate disks on a per-test or per item
basis.</p></div>
</div>
|
︙ | | |
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
|
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
|
-
|
# This builtin rule is the default if there is no <waivername>.logpro file
# diff diff %file1% %file2%
# This builtin rule is applied if a <waivername>.logpro file exists
# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html</pre>
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_ezsteps">Ezsteps</h3>
<div class="listingblock">
<div class="title">Example ezsteps with logpro rules</div>
<div class="content monospaced">
<pre>[ezsteps]
|
︙ | | |
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
|
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
|
-
-
|
<div class="listingblock">
<div class="title">For test "runfirst" override the toplevel generation with a script "mysummary.sh"</div>
<div class="content monospaced">
<pre># Override the rollup for specific tests
[testrollup]
runfirst mysummary.sh</pre>
</div></div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_archiving_setup">Archiving Setup</h2>
<div class="sectionbody">
<div class="paragraph"><p>In megatest.config add the following sections:</p></div>
<div class="listingblock">
<div class="title">megatest.config</div>
|
︙ | | |
Modified docs/manual/reference.txt
from [ae56b797b4]
to [88bde1cc13].
︙ | | |
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
-
-
+
|
.Testconfig for Test C
----------------------
[requirements]
waiton A B
[itemmap]
A (\d+)/aa aa/\1
B (\d+)/bb bb/\1
----------------------
B (\d+)/bb --------------------
.Testconfig for Test D
----------------------
[requirements]
waiton C
itemmap (\d+)/res \1/aa
----------------------
|
︙ | | |
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
|
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
|
-
+
+
|
.Autogeneration waiton list for dynamic flow dependency trees
-------------------
[requirements]
# With a toplevel test you may wish to generate your list
# of tests to run dynamically
#
# waiton #{shell get-valid-tests-to-run.sh}
waiton #{shell get-valid-tests-to-run.sh}
-------------------
Run time limit
^^^^^^^^^^^^^^
-----------------
[requirements]
runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s
-----------------
Skip
^^^^
A test with a skip section will conditional skip running.
|
︙ | | |
Modified rmt.scm
from [7c256785ed]
to [58033889c8].
︙ | | |
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
|
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
|
-
-
+
+
|
(map (lambda (run-id)
(rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
run-ids))))
;; (define (rmt:get-run-ids-matching keynames target res)
;; (rmt:send-receive #f 'get-run-ids-matching (list keynames target res)))
(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmaps #f))
(rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode itemmaps)))
(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
(rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))
(define (rmt:get-count-tests-running-for-run-id run-id)
(rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
;; Statistical queries
(define (rmt:get-count-tests-running run-id)
|
︙ | | |
Modified runs.scm
from [e714363b54]
to [93791638c8].
︙ | | |
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
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
|
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
|
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
+
-
-
+
+
+
|
;;======================================================================
(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.
(setenv "MT_TEST_NAME" hed) ;;
(let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs))
(let*-values (((waitons waitors config)(tests:get-waitons hed all-tests-registry)))
(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)))))
(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)
res))
((string? instr) instr)
(else
;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed)
"")))))
(filter (lambda (x)
(if (hash-table-ref/default all-tests-registry x #f)
#t
(begin
(debug:print 0 "ERROR: test " hed " has unrecognised waiton testname " x)
#f)))
newwaitons)))))
(debug:print-info 8 "waitons: " waitons)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (or (member hed waitons)
(if (member hed waitons)
(member hed waitors))
(begin
(debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!")
(set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))))
(debug:print 0 "ERROR: test " hed " has listed itself as a waiton or waitor, please correct this!")
(set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))
(set! waitors (filter (lambda (x)(not (equal? x hed))) waitors))))
;; (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 ;; 0
config ;; 1
waitons ;; 2
|
︙ | | |
412
413
414
415
416
417
418
419
420
421
422
423
424
425
|
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
|
+
|
((or (list? items)(list? itemstable)) ;; calc now
(debug:print-info 4 "items and itemstable are lists, calc now\n"
" items: " items " itemstable: " itemstable)
(items:get-items-from-config config))
(else #f))) ;; not iterated
#f ;; itemsdat 5
#f ;; spare - used for item-path
waitors ;;
)))
(for-each
(lambda (waiton)
(if (and waiton (not (member waiton test-names)))
(let* ((waiton-record (hash-table-ref/default test-records waiton #f))
(waiton-tconfig (if waiton-record (vector-ref waiton-record 1) #f))
(waiton-itemized (and waiton-tconfig
|
︙ | | |
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
|
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
|
-
+
|
;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts
;; - doesn't work
;; (set! test-patts (conc test-patts "," waiton "/"))
;; (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
)))
waitons)
(delete-duplicates (append waitons waitors)))
(let ((remtests (delete-duplicates (append waitons tal))))
(if (not (null? remtests))
(begin
;; (debug:print-info 0 "Preprocessing continues for " (string-intersperse remtests ", "))
(loop (car remtests)(cdr remtests))))))))
(if (not (null? required-tests))
|
︙ | | |
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
|
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
|
-
+
|
'()
reg)))
(define runs:nothing-left-in-queue-count 0)
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps)
(let* ((loop-list (list hed tal reg reruns))
(prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmaps: itemmaps))
(prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
(fails (runs:calc-fails prereqs-not-met))
(prereq-fails (runs:calc-prereq-fail prereqs-not-met))
(non-completed (runs:calc-not-completed prereqs-not-met))
(runnables (runs:calc-runnable prereqs-not-met)))
(debug:print-info 4 "START OF INNER COND #2 "
"\n can-run-more: " can-run-more
|
︙ | | |
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
|
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
|
-
+
|
(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps)
(let* ((run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
(have-resources (car run-limits-info))
(num-running (list-ref run-limits-info 1))
(num-running-in-jobgroup (list-ref run-limits-info 2))
(max-concurrent-jobs (list-ref run-limits-info 3))
(job-group-limit (list-ref run-limits-info 4))
(prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmaps: itemmaps))
(prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
(fails (runs:calc-fails prereqs-not-met))
(non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed!
(not (equal? x hed)))
(runs:calc-not-completed prereqs-not-met)))
(loop-list (list hed tal reg reruns))
;; configure the load runner
|
︙ | | |
Added supplemental.megatest.config version [5180103602].
|
1
2
3
|
+
+
+
|
[tests-paths]
nada #{getenv MT_RUN_AREA_HOME}/moretests
|
| |
Modified tests.scm
from [4e99e09e2a]
to [d77069491a].
︙ | | |
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
137
138
|
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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
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
|
-
+
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
-
-
+
+
-
-
+
+
-
+
-
-
-
+
+
+
|
;; # itemmap entry in requirements (legacy). The itemmap
;; # requirements entry is deprecated
;;
(define (tests:get-itemmaps tconfig)
(let ((base-itemmap (configf:lookup tconfig "requirements" "itemmap"))
(itemmap-table (configf:get-section tconfig "itemmap")))
(append (if base-itemmap
(list (cons "%" base-itemmap))
(list (list "%" base-itemmap))
'())
(if itemmap-table
itemmap-table
'()))))
;; given a list of itemmaps (testname . map), return the first match
;;
(define (tests:lookup-itemmap itemmaps testname)
(let ((best-matches (filter (lambda (itemmap)
(tests:match (car itemmap) testname))
(tests:match (car itemmap) testname #f))
itemmaps)))
(if (null? best-matches)
#f
(car best-matches))))
(let ((res (car best-matches)))
(debug:print 0 "res=" res)
(cond
((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
((null? res) #f)
((string? (cdr res)) (cdr res)) ;; it is a pair
((string? (cadr res))(cadr res)) ;; it is a list
(else cadr res))))))
;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
(let* ((config (tests:get-testconfig test-name all-tests-registry 'return-procs)))
(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 \"" test-name "\"")
(exit 1))))
(instr2 (if config
(config-lookup config "requirements" "waitor")
"")))
(debug:print-info 8 "waitons string is " instr ", waitors string is " instr2)
(let ((newwaitons
(string-split (cond
((procedure? instr)
(let ((res (instr)))
(debug:print-info 8 "waiton procedure results in string " res " for test " test-name)
res))
((string? instr) instr)
(else
;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " test-name)
""))))
(newwaitors
(string-split (cond
((procedure? instr2)
(let ((res (instr2)))
(debug:print-info 8 "waitor procedure results in string " res " for test " test-name)
res))
((string? instr2) instr2)
(else
;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " test-name)
"")))))
(values
;; the waitons
(filter (lambda (x)
(if (hash-table-ref/default all-tests-registry x #f)
#t
(begin
(debug:print 0 "ERROR: test " test-name " has unrecognised waiton testname " x)
#f)))
newwaitons)
(filter (lambda (x)
(if (hash-table-ref/default all-tests-registry x #f)
#t
(begin
(debug:print 0 "ERROR: test " test-name " has unrecognised waiton testname " x)
#f)))
newwaitors)
config)))))
;; given test-b that is waiting on test-a extend test-patt appropriately
;; given waiting-test that is waiting on waiton-test extend test-patt appropriately
;;
;; genlib/testconfig sim/testconfig
;; genlib/sch sim/sch/cell1
;;
;; [requirements] [requirements]
;; mode itemwait
;; # trim off the cell to determine what to run for genlib
;; itemmap /.*
;;
;; test-a is waiting on test-b so we need to create a pattern for test-b given test-a and itemmap
(define (tests:extend-test-patts test-patt test-b test-a itemmaps)
(let* ((itemmap (tests:lookup-itemmap itemmaps test-b))
;; waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap
(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps)
(let* ((itemmap (tests:lookup-itemmap itemmaps waiton-test))
(patts (string-split test-patt ","))
(test-b-len (+ (string-length test-b) 1))
(patts-b (map (lambda (x)
(waiting-test-len (+ (string-length waiting-test) 1))
(patts-waiton (map (lambda (x) ;; for each incoming patt that matches the waiting test
(let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x))
(newpatt (conc test-a "/" (substring modpatt test-b-len (string-length modpatt)))))
;; (conc test-a "/," test-a "/" (substring modpatt test-b-len (string-length modpatt)))))
(newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
;; (print "in map, x=" x ", newpatt=" newpatt)
newpatt))
(filter (lambda (x)
(eq? (substring-index (conc test-b "/") x) 0))
(eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
patts))))
(string-intersperse (delete-duplicates (append patts (if (null? patts-b)
(list (conc test-a "/%"))
patts-b)))
(string-intersperse (delete-duplicates (append patts (if (null? patts-waiton)
(list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
patts-waiton)))
",")))
;; tests:glob-like-match
(define (tests:glob-like-match patt str)
(let ((like (substring-index "%" patt)))
(let* ((notpatt (equal? (substring-index "~" patt) 0))
(newpatt (if notpatt (substring patt 1) patt))
|
︙ | | |
Modified tests/tests.scm
from [9d9074d93d]
to [8b81d25a98].
︙ | | |
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
+
+
|
;; PURPOSE.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(require-extension test)
(require-extension regex)
(require-extension srfi-18)
(require-extension posix)
(import posix)
(import srfi-18)
;; (require-extension zmq)
;; (import zmq)
(define test-work-dir (current-directory))
;; read in all the _record files
|
︙ | | |