Check-in [3aeabde95d]
Not logged in
Overview
SHA1 Hash:3aeabde95dcc1fde02d12b9b09f33e1bd0c0e0f9
Date: 2011-11-21 05:36:08
User: matt
Comment:commit of re-hacked run code. completely torn to shreds and rewritten
Timelines: family | ancestors | descendants | both | reorg-runs-code
Downloads: Tarball | ZIP archive
Other Links: files | file ages | folders | manifest
Tags And Properties
Changes

Modified configf.scm from [ef264b880e908b66] to [e31d2a9565823c2f].

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
	       (blank-l-rx _                  (loop (read-line inp) curr-section-name #f #f))
	       (include-rx ( x include-file ) (begin
						(read-config include-file res allow-system environ-patt: environ-patt)
						(loop (read-line inp) curr-section-name #f #f)))
	       (section-rx ( x section-name ) (loop (read-line inp) section-name #f #f))
	       (key-sys-pr ( x key cmd      ) (if allow-system
						  (let ((alist (hash-table-ref/default res curr-section-name '()))

							(val   (let* ((cmdres  (cmd-run->list cmd))
								      (status  (cadr cmdres))
								      (res     (car  cmdres)))
								 (if (not (eq? status 0))
								     (begin
								       (debug:print 0 "ERROR: problem with " inl ", return code " status)
								       (exit 1)))
								 (if (null? res)
								     ""
								     (string-intersperse res " ")))))
						    (hash-table-set! res curr-section-name 
								     (config:assoc-safe-add alist key val))




						    (loop (read-line inp) curr-section-name #f #f))
						  (loop (read-line inp) curr-section-name #f #f)))
	       (key-val-pr ( x key val      ) (let* ((alist   (hash-table-ref/default res curr-section-name '()))
						     (envar   (and environ-patt (string-match (regexp environ-patt) curr-section-name)))
						     (realval (if envar
								 (config:eval-string-in-environment val)
								 val)))







>
|
|
|
|
|
|
|
|
|
|

|
>
>
>
>







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
	       (blank-l-rx _                  (loop (read-line inp) curr-section-name #f #f))
	       (include-rx ( x include-file ) (begin
						(read-config include-file res allow-system environ-patt: environ-patt)
						(loop (read-line inp) curr-section-name #f #f)))
	       (section-rx ( x section-name ) (loop (read-line inp) section-name #f #f))
	       (key-sys-pr ( x key cmd      ) (if allow-system
						  (let ((alist (hash-table-ref/default res curr-section-name '()))
							(val-proc (lambda ()
								    (let* ((cmdres  (cmd-run->list cmd))
									   (status  (cadr cmdres))
									   (res     (car  cmdres)))
								      (if (not (eq? status 0))
									  (begin
									    (debug:print 0 "ERROR: problem with " inl ", return code " status)
									    (exit 1)))
								      (if (null? res)
									  ""
									  (string-intersperse res " "))))))
						    (hash-table-set! res curr-section-name 
								     (config:assoc-safe-add alist
											    key 
											    (if (eq? allow-system 'return-procs)
												val
												(val))))
						    (loop (read-line inp) curr-section-name #f #f))
						  (loop (read-line inp) curr-section-name #f #f)))
	       (key-val-pr ( x key val      ) (let* ((alist   (hash-table-ref/default res curr-section-name '()))
						     (envar   (and environ-patt (string-match (regexp environ-patt) curr-section-name)))
						     (realval (if envar
								 (config:eval-string-in-environment val)
								 val)))

Modified db.scm from [65214cf6f39701d4] to [c39ab57eb703aaa5].

111
112
113
114
115
116
117

118
119
120
121
122
123
124
...
205
206
207
208
209
210
211



212
213
214
215
216
217
218
...
414
415
416
417
418
419
420













421
422
423
424
425
426
427
...
692
693
694
695
696
697
698




























699
700
701
702
703
704
705
                                     owner       TEXT DEFAULT '',
                                     description TEXT DEFAULT '',
                                     reviewed    TIMESTAMP,
                                     iterated    TEXT DEFAULT '',
                                     avg_runtime REAL,
                                     avg_disk    REAL,
                                     tags        TEXT DEFAULT '',

                                CONSTRAINT test_meta_constraint UNIQUE (testname));")
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
                                test_id INTEGER,
                                category TEXT DEFAULT '',
                                variable TEXT,
	                        value REAL,
	                        expected REAL,
................................................................................
       (db:set-var db "MEGATEST_VERSION" 1.27)
       (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';")
       (patch-db))
      ((< mver 1.29)
       (db:set-var db "MEGATEST_VERSION" 1.29)
       (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';")
       (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';"))



      ((< mver megatest-version)
       (db:set-var db "MEGATEST_VERSION" megatest-version))))))

;;======================================================================
;; meta get and set vars
;;======================================================================

................................................................................
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART';")
    res))














;; done with run when:
;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining db run-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
................................................................................
		      (for-each (lambda (test)
				  (if (equal? waitontest-name (db:test-get-testname test))
				      (begin
					(set! ever-seen #t)
					(if (not (and (equal? (db:test-get-state test) "COMPLETED")
						      (member (db:test-get-status test) '("PASS" "WARN" "CHECK"))))
					    (set! result (cons waitontest-name result))))))




























				tests)
		      (if (not ever-seen)(set! result (cons waitontest-name result)))))
		  waiton)
	(delete-duplicates result))))

;;======================================================================
;; Extract ods file from the db







>







 







>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
...
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
...
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
...
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
749
750
                                     owner       TEXT DEFAULT '',
                                     description TEXT DEFAULT '',
                                     reviewed    TIMESTAMP,
                                     iterated    TEXT DEFAULT '',
                                     avg_runtime REAL,
                                     avg_disk    REAL,
                                     tags        TEXT DEFAULT '',
                                     jobgroup    TEXT DEFAULT 'default',
                                CONSTRAINT test_meta_constraint UNIQUE (testname));")
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
                                test_id INTEGER,
                                category TEXT DEFAULT '',
                                variable TEXT,
	                        value REAL,
	                        expected REAL,
................................................................................
       (db:set-var db "MEGATEST_VERSION" 1.27)
       (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';")
       (patch-db))
      ((< mver 1.29)
       (db:set-var db "MEGATEST_VERSION" 1.29)
       (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';")
       (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';"))
      ((< mver 1.36)
       (db:set-var db "MEGATEST_VERSION" 1.36)
       (sqlite3:execute db "ALTER TABLER test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';"))
      ((< mver megatest-version)
       (db:set-var db "MEGATEST_VERSION" megatest-version))))))

;;======================================================================
;; meta get and set vars
;;======================================================================

................................................................................
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART';")
    res))

(define (db:get-count-tests-running-in-jobgroup db jobgroup)
  (if (not jobgroup)
      0 ;; 
      (let ((res 0))
	(sqlite3:for-each-row
	 (lambda (count)
	   (set! res count))
	 db
	 "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART'
             AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?;"
	 jobgroup)
	res)))

;; done with run when:
;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining db run-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
................................................................................
		      (for-each (lambda (test)
				  (if (equal? waitontest-name (db:test-get-testname test))
				      (begin
					(set! ever-seen #t)
					(if (not (and (equal? (db:test-get-state test) "COMPLETED")
						      (member (db:test-get-status test) '("PASS" "WARN" "CHECK"))))
					    (set! result (cons waitontest-name result))))))
				tests)
		      (if (not ever-seen)(set! result (cons waitontest-name result)))))
		  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)
      '()
      (let* ((unmet-pre-reqs '())
	     (tests           (db-get-tests-for-run db run-id #f #f '() '()))
	     (result         '()))
	(for-each (lambda (waitontest-name)
		    (let ((ever-seen #f))
		      (for-each (lambda (test)
				  (if (equal? waitontest-name (db:test-get-testname test))
				      (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-ok         (member status '("PASS" "WARN" "CHECK" "WAIVED")))
					     (same-itempath (equal? ref-item-path item-path)))
					(set! ever-seen #t)
					(if (or (
					    (set! result (cons waitontest-name result))))))
				tests)
		      (if (not ever-seen)(set! result (cons waitontest-name result)))))
		  waiton)
	(delete-duplicates result))))

;;======================================================================
;; Extract ods file from the db

Modified megatest-version.scm from [c9e5e7d31e1201ff] to [27dcca54210e5a68].

1
2
3
4
5
6
7
;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.34)






|

1
2
3
4
5
6
7
;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.36)

Modified runs.scm from [253a55cec5467d66] to [9e5179a7af8cc41e].

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
...
153
154
155
156
157
158
159

160
161
162
163
164
165
166
167
...
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209

210
211
212
213
214
215
216
...
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
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
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
392
393
394
395
396
397
398
399
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
430
431
432
433
434
435
436
437
...
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618

(define (set-item-env-vars itemdat)
  (for-each (lambda (item)
	      (debug:print 2 "setenv " (car item) " " (cadr item))
	      (setenv (car item) (cadr item)))
	    itemdat))

(define (runs:can-run-more-tests db)


  (let ((num-running (db:get-count-tests-running db))

	(max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")))

    (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
    (if (not (eq? 0 *globalexitstatus*))
	#f

	(if (or (not max-concurrent-jobs)

		(and max-concurrent-jobs
		     (string->number max-concurrent-jobs)
		     (not (>= num-running (string->number max-concurrent-jobs)))))
	    #t
	    (begin 
	      (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running 
			   ", max_concurrent_jobs: " max-concurrent-jobs)








	      #f)))))



;;======================================================================
;; 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
(define (runs:run-tests db target runname test-patts item-patts user flags)
  (let* ((keys        (db-get-keys db))
	 (keyvallst   (keys:target->keyval keys target))
	 (run-id      (runs:register-run db keys keyvallst runname "new" "n/a" user))  ;;  test-name)))
	 (deferred    '()) ;; delay running these since they have a waiton clause

	 (keepgoing   (hash-table-ref/default flags "-keepgoing" #f))
	 (test-names  '())
	 (runconfigf   (conc  *toppath* "/runconfigs.config"))
	 (required-tests '())
	 (test-records (make-hash-table)))

    (set-megatest-env-vars db run-id) ;; these may be needed by the launching process

................................................................................
	  ;; 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.
	  (db:delete-tests-in-state db run-id "NOT_STARTED")
	  (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))

    (set! *passnum* (+ *passnum* 1))

    ;; now add non-directly referenced dependencies (i.e. waiton)
    (if (not (null? test-names))
	(let loop ((hed (car test-names))
		   (tal (cdr test-names)))
	  (let* ((config  (test:get-testconfig hed #f))
		 (waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))
					  (if w w "")))))

	    (if (not (hash-table-ref/default test-records hed #f))
		(hash-table-set! test-records hed (vector hed config waitons (config-lookup "requirements" "priority") #f)))
	    (for-each 
	     (lambda (waiton)
	       (if (and waiton (not (member waiton test-names)))
		   (begin
		     (set! required-tests (cons waiton required-tests))
................................................................................
	     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"))




    ;; At this point the list of parent tests is expanded 
    ;; NB// Should expand items here and then insert into the run queue.
    (let loop ((numtimes 0))

































      (for-each 






       (lambda (test-record)
	 ;; need to inspect the items field tests:testqueue-get-items
	 ;;
	 ;;  if #f then no items for this test, check prereqs and launch
	 ;; 
	 ;;  else if list, then have items
	 ;;
	 ;; if proc then eval it.
	 ;;
	 (let ((items (items:get-items-from-config tconfig)))


















	 (if (runs:can-run-more-tests db test-record) ;; now needs to look at the test group
	     (run:test db run-id runname test-name keyvallst item-patts flags)
	     ))
       (tests:sort-by-priority-and-waiton test-records))
      ;; (run-waiting-tests db)
      (if keepgoing
	  (let ((estrem (db:estimated-tests-remaining db run-id)))
	    (if (and (> estrem 0)
		     (eq? *globalexitstatus* 0))


		(begin
		  (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...")







		  (thread-sleep! 3)
		  (run-waiting-tests db)
		  (loop (+ numtimes 1)))))))))












(define (run:test db run-id runname test-name keyvallst item-patts 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-path    (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	 (test-conf    (if testexists (read-config test-configf #f #t) (make-hash-table)))
	 (waiton       (let ((w (config-lookup test-conf "requirements" "waiton")))
			 (if (string? w)(string-split w)'())))


	 (force        (hash-table-ref/default flags "-force" #f))
	 (rerun        (hash-table-ref/default flags "-rerun" #f))
	 (keepgoing    (hash-table-ref/default flags "-keepgoing" #f))
	 ;; Are these tags still used? I don't think so...
	 ;;(tags         (let ((t (config-lookup test-conf "setup" "tags")))
	 ;;       	 ;; we want our tags to be separated by commas and fully delimited by commas
	 ;;       	 ;; so that queries with "like" can tie to the commas at either end of each tag
	 ;;       	 ;; while also allowing the end user to freely use spaces and commas to separate tags
	 ;;       	 (if (string? t)(string-substitute (regexp "[,\\s]+") "," (conc "," t ",") #t)
	 ;;       	     '()))))
	 )
    (if (not testexists)
	;; if the test is ill defined spit out an error but keep going (different from how done previously
	(debug:print 0 "ERROR: Can't find config file " test-configf)
	;; put top vars into convenient variables and open the db
	(let* (;; db is always at *toppath*/db/megatest.db
	       (items       (hash-table-ref/default test-conf "items" '()))
	       (itemstable  (hash-table-ref/default test-conf "itemstable" '()))
	       (allitems    (if (or (not (null? items))(not (null? itemstable)))
				(append (item-assoc->item-list items)
					(item-table->item-list itemstable))
				'(())))) ;; a list with one null list is a test with no items
	  ;; (runconfigf  (conc  *toppath* "/runconfigs.config")))
	  (debug:print 1 "items: ")
	  (if (>= *verbosity* 1)(pp allitems))
	  (if (>= *verbosity* 5)
	      (begin
		(print "items: ")(pp (item-assoc->item-list items))
		(print "itemstable: ")(pp (item-table->item-list itemstable))))

	  ;; Comments are loaded by the test run, not at launch time (in general)
	  ;;(if (args:get-arg "-m")
	  ;;    (db:set-comment-for-run db run-id (args:get-arg "-m")))

	  ;; Here is where the test_meta table is best updated
	  (runs:update-test_meta db test-name test-conf)

	  ;; braindead work-around for poorly specified allitems list BUG!!! FIXME
	  (if (null? allitems)(set! allitems '(())))
	  (let loop ((itemdat (car allitems))
		     (tal     (cdr allitems)))
	    ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
	    ;; Handle lists of items
	    (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)
		   (num-running (db:get-count-tests-running db))
		   (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))
		   (parent-test (and (not (null? items))(equal? item-path "")))
		   (single-test (and (null? items) (equal? item-path "")))
		   (item-test   (not (equal? item-path "")))
		   ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is %
		   (item-matches (if item-patts
				     (let ((res #f))
				       (for-each 
					(lambda (patt)
					  (if (string-search (glob->regexp
							      (string-translate patt "%" "*"))
							     item-path)
					      (set! res #t)))
					(string-split item-patts ","))
				       res)
				     #t)))
	      (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
	      (if (and item-matches (runs:can-run-more-tests db))
		  (begin
		    (let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #f)
				(ct 0))
		      (if (and (not ts)
			       (< ct 10))
			  (begin
			    (register-test db run-id test-name item-path)
			    ;; Why did I set the comment here?!? POSSIBLE BUG BUT I'M REMOVING IT FOR NOW 10/23/2011
			    ;; (db:test-set-comment db run-id test-name item-path "")
			    (loop2 (db:get-test-info db run-id test-name item-path)
				   (+ ct 1)))
			  (if ts
			      (set! testdat ts)
			      (begin
				(debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
				(if (not (null? tal))
				    (loop (car tal)(cdr tal)))))))
		    (change-directory test-path)
		    ;; this block is here only to inform the user early on
		    
		    ;; Moving this to the run calling block

		    ;; (if (file-exists? runconfigf)
		    ;;     (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*)
		    ;;     (debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
		    (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"))
		      ((NOT_STARTED COMPLETED)
		       (debug:print 6 "Got here, " (test:get-state testdat))
		       (let ((runflag #f))
			 (cond
			  ;; i.e. this is the parent test to a suite of items, never "run" it
			  (parent-test
			   (set! runflag #f))
			  ;; -force, run no matter what
			  (force (set! runflag #t))
			  ;; NOT_STARTED, run no matter what
			  ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t))
			  ;; not -rerun and PASS, WARN or CHECK, do no run
			  ((and (or (not rerun)
				    keepgoing)
				(member (test:get-status testdat) '("PASS" "WARN" "CHECK")))
			   (set! runflag #f))
			  ;; -rerun and status is one of the specifed, run it
			  ((and rerun
				(let ((rerunlst (string-split rerun ","))) ;; FAIL,
				  (member (test:get-status testdat) rerunlst)))
			   (set! runflag #t))
			  ;; -keepgoing, do not rerun FAIL
			  ((and keepgoing
				(member (test:get-status testdat) '("FAIL")))
			   (set! runflag #f))
			  ((and (not rerun)
				(member (test:get-status testdat) '("FAIL" "n/a")))
			   (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 ....
				    (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...
				   (if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host
				       (begin
					 (print "ERROR: Failed to launch the test. Exiting as soon as possible")
					 (set! *globalexitstatus* 1) ;; 
					 (process-signal (current-process-id) signal/kill)
					 ;(exit 1)
					 ))
				   (if (not keepgoing)
				       (hash-table-set! *waiting-queue* new-test-name testrundat)))))))
		      ((KILLED) 
		       (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
		      ((LAUNCHED REMOTEHOSTSTART RUNNING)  
		       (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
						     (db:test-get-run_duration testdat)))
			      100) ;; i.e. no update for more than 100 seconds
			   (begin
			     (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
			     (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead" #f))
			   (debug:print 2 "NOTE: " test-name " is already running")))
		      (else       (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))
	      (if (not (null? tal))
		  (loop (car tal)(cdr tal)))))))))

;;======================================================================
;; END OF NEW STUFF
;;======================================================================

(define (get-dir-up-n dir . params) 
  (let ((dparts  (string-split dir "/"))
................................................................................
  (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user)
  (let* (; (keyvalllst      (keys:target->keyval keys target))
	 (new-run-id      (runs:register-run db keys keyvallst runname "new" "n/a" user))
	 (prev-tests      (test:get-matching-previous-test-run-records db new-run-id "%" "%"))
	 (curr-tests      (db-get-tests-for-run db new-run-id "%" "%" '() '()))
	 (curr-tests-hash (make-hash-table)))
    (db:update-run-event_time db new-run-id)
    ;; index the already saved tests by testname and itempath in curr-tests-hash
    (for-each
     (lambda (testdat)
       (let* ((testname  (db:test-get-testname testdat))
	      (item-path (db:test-get-item-path testdat))
	      (full-name (conc testname "/" item-path)))
	 (hash-table-set! curr-tests-hash full-name testdat)))
     curr-tests)







|
>
>
|
>
|
>



>
|
>
|
|
|
<
<
|
|
>
>
>
>
>
>
>
>
|
<
>







 







>
|







 







<
<



|
|

|
>







 







>
>

>


<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
|
<
<
<
<
<
<
<
<
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
<
<
<
<
<
<
<
>
>
|
<
>
>
>
>
>
>
>
|
<
<
>

>
>
>
>
>
>
>
>
>
>
|






>
|
<
<
<
<
<
>
>


|
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
<
<
<
<
|
<
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<







 







|







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
...
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
...
207
208
209
210
211
212
213


214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
...
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
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
392
393
394
395
396
397
398
399
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
...
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606

(define (set-item-env-vars itemdat)
  (for-each (lambda (item)
	      (debug:print 2 "setenv " (car item) " " (cadr item))
	      (setenv (car item) (cadr item)))
	    itemdat))

(define (runs:can-run-more-tests db test-record)
  (let* ((tconfig                 (tests:testqueue-get-testconfig test-record))
	 (jobgroup                (config-lookup tconfig "requirements" "jobgroup"))
	 (num-running             (db:get-count-tests-running db))
	 (num-running-in-jobgroup (db:get-count-tests-running-in-jobgroup db jobgroup))
	 (max-concurrent-jobs     (config-lookup *configdat* "setup"     "max_concurrent_jobs"))
	 (job-group-limit         (config-lookup *configdat* "jobgroups" jobgroup)))
    (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
    (if (not (eq? 0 *globalexitstatus*))
	#f
	(let ((can-not-run-more (cond
				 ;; if max-concurrent-jobs is set and the number running is greater 
				 ;; than it than cannot run more jobs
				 ((and max-concurrent-jobs
				       (string->number max-concurrent-jobs)
				       (>= num-running (string->number max-concurrent-jobs)))


				  (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running 
					       ", max_concurrent_jobs: " max-concurrent-jobs)
				  #t)
				 ;; if job-group-limit is set and number of jobs in the group is greater
				 ;; than the limit then cannot run more jobs of this kind
				 ((and job-group-limit
				       (>= 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))))

	  (not can-not-run-more)))))

;;======================================================================
;; 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
(define (runs:run-tests db target runname test-patts item-patts user flags)
  (let* ((keys        (db-get-keys db))
	 (keyvallst   (keys:target->keyval keys target))
	 (run-id      (runs:register-run db keys keyvallst 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))
	 (test-names  '())
	 (runconfigf   (conc  *toppath* "/runconfigs.config"))
	 (required-tests '())
	 (test-records (make-hash-table)))

    (set-megatest-env-vars db run-id) ;; these may be needed by the launching process

................................................................................
	  ;; 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.
	  (db:delete-tests-in-state db run-id "NOT_STARTED")
	  (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))



    ;; 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  (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 "requirements" "priority") #f)))
	    (for-each 
	     (lambda (waiton)
	       (if (and waiton (not (member waiton test-names)))
		   (begin
		     (set! required-tests (cons waiton required-tests))
................................................................................
	     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)))

(define (runs:run-tests-queue  test-records keyvallist)
    ;; At this point the list of parent tests is expanded 
    ;; NB// Should expand items here and then insert into the run queue.

    (let ((sorted-testnames (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)))
	  (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)))
	      (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
		    (thread-sleep! 1)
		    (loop (car tal)(cdr tal))))))
	   
	   ;; case where an items came in as a list been processed
	   ((and (list? items)     ;; thus we know our items are already calculated
		 (not   itemdat)) ;; and not yet expanded into the list of things to be done
	    (if (>= *verbosity* 1)(pp items))
	    ;; (if (>= *verbosity* 5)
	    ;;     (begin
	    ;;       (print "items: ")     (pp (item-assoc->item-list items))
	    ;;       (print "itemstable: ")(pp (item-table->item-list itemstable))))
	    (for-each
	     (lambda (my-itemdat)
	       (let* ((new-test-record (vector-copy! test-record (make-tests:testqueue)))
		      (my-item-path (item-list->path my-itemdat))
		      (item-matches (if item-patts       ;; here we are filtering for matches with -itempatt
					(let ((res #f))	 ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is %
					  (for-each 
					   (lambda (patt)









					     (if (string-search (glob->regexp
								 (string-translate patt "%" "*"))
								item-path)
						 (set! res #t)))
					   (string-split item-patts ","))
					  res)
					#t)))
		 (if item-matches ;; yes, we want to process this item
		     (begin
		       (tests:testqueue-set-items!   new-test-record #f)
		       (tests:testqueue-set-itemdat! new-test-record my-itemdat)
		       (set! tal (cons (conc hed "/" my-item-path) tal)))))) ;; since these are itemized create new test names testname/itempath
	     items)
	    (loop (car tal)(cdr tal)))

	   ;; if items is a proc then need to evaluate, get the list and loop - but only do that if 
	   ;; resources exist to kick off the job
	   ((procedure? items)
	    (if (runs:can-run-more-tests db test-record)








		(let ((items-list (items)))
		  (if (list? items-list)
		      (begin

			(tests:testqueue-set-items test-record items-list)
			(loop hed tal))
		      (begin
			(debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
			(exit 1))))
		(let ((newtal (append tal (list hed))))
		  ;; if can't run more tests, lets take a breather
		  (thread-sleep! 1)


		  (loop (car newtal)(cdr newtal)))))

	   ;; this case should not happen, added to help catch any bugs
	   ((and (list? items) itemdat)
	    (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this")
	    (exit 1)))
	  
	  ;; 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)))































    ;; 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"))
	((NOT_STARTED COMPLETED)
	 (debug:print 6 "Got here, " (test:get-state testdat))
	 (let ((runflag #f))
	   (cond



	    ;; -force, run no matter what
	    (force (set! runflag #t))
	    ;; NOT_STARTED, run no matter what
	    ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t))
	    ;; not -rerun and PASS, WARN or CHECK, do no run
	    ((and (or (not rerun)
		      keepgoing)
		  (member (test:get-status testdat) '("PASS" "WARN" "CHECK")))
	     (set! runflag #f))
	    ;; -rerun and status is one of the specifed, run it
	    ((and rerun
		  (let ((rerunlst (string-split rerun ","))) ;; FAIL,
		    (member (test:get-status testdat) rerunlst)))
	     (set! runflag #t))
	    ;; -keepgoing, do not rerun FAIL
	    ((and keepgoing
		  (member (test:get-status testdat) '("FAIL")))
	     (set! runflag #f))
	    ((and (not rerun)
		  (member (test:get-status testdat) '("FAIL" "n/a")))
	     (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 ....
		      (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...
		     (if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host
			 (begin
			   (print "ERROR: Failed to launch the test. Exiting as soon as possible")
			   (set! *globalexitstatus* 1) ;; 
			   (process-signal (current-process-id) signal/kill)
					;(exit 1)
			   ))
		     (if (not keepgoing)
			 (hash-table-set! *waiting-queue* new-test-name testrundat)))))))
	((KILLED) 
	 (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
	((LAUNCHED REMOTEHOSTSTART RUNNING)  
	 (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
				       (db:test-get-run_duration testdat)))
		600) ;; i.e. no update for more than 600 seconds
	     (begin
	       (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
	       (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead" #f))
	     (debug:print 2 "NOTE: " test-name " is already running")))
	(else       (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat)))))))



;;======================================================================
;; END OF NEW STUFF
;;======================================================================

(define (get-dir-up-n dir . params) 
  (let ((dparts  (string-split dir "/"))
................................................................................
  (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user)
  (let* (; (keyvalllst      (keys:target->keyval keys target))
	 (new-run-id      (runs:register-run db keys keyvallst runname "new" "n/a" user))
	 (prev-tests      (test:get-matching-previous-test-run-records db new-run-id "%" "%"))
	 (curr-tests      (db-get-tests-for-run db new-run-id "%" "%" '() '()))
	 (curr-tests-hash (make-hash-table)))
    (db:update-run-event_time db new-run-id)
    ;; index the already saved tests by testname and itemdat in curr-tests-hash
    (for-each
     (lambda (testdat)
       (let* ((testname  (db:test-get-testname testdat))
	      (item-path (db:test-get-item-path testdat))
	      (full-name (conc testname "/" item-path)))
	 (hash-table-set! curr-tests-hash full-name testdat)))
     curr-tests)

Modified test_records.scm from [1c9875ade7275430] to [7236ce28391e9ea2].

1
2
3
4
5
6

7

8
9
10
11
12
13

;; make-vector-record tests testqueue testname testconfig waitons priority items
(define (make-tests:testqueue)(make-vector 5))
(define-inline (tests:testqueue-get-testname     vec)    (vector-ref  vec 0))
(define-inline (tests:testqueue-get-testconfig   vec)    (vector-ref  vec 1))
(define-inline (tests:testqueue-get-waitons      vec)    (vector-ref  vec 2))
(define-inline (tests:testqueue-get-priority     vec)    (vector-ref  vec 3))

(define-inline (tests:testqueue-get-items        vec)    (vector-ref  vec 4))


(define-inline (tests:testqueue-set-testname!    vec val)(vector-set! vec 0 val))
(define-inline (tests:testqueue-set-testconfig!  vec val)(vector-set! vec 1 val))
(define-inline (tests:testqueue-set-waitons!     vec val)(vector-set! vec 2 val))
(define-inline (tests:testqueue-set-priority!    vec val)(vector-set! vec 3 val))
(define-inline (tests:testqueue-set-items!       vec val)(vector-set! vec 4 val))


|




>

>






>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
;; make-vector-record tests testqueue testname testconfig waitons priority items
(define (make-tests:testqueue)(make-vector 6 #f))
(define-inline (tests:testqueue-get-testname     vec)    (vector-ref  vec 0))
(define-inline (tests:testqueue-get-testconfig   vec)    (vector-ref  vec 1))
(define-inline (tests:testqueue-get-waitons      vec)    (vector-ref  vec 2))
(define-inline (tests:testqueue-get-priority     vec)    (vector-ref  vec 3))
;; items: #f=no items, list=list of items remaining, proc=need to call to get items
(define-inline (tests:testqueue-get-items        vec)    (vector-ref  vec 4))
(define-inline (tests:testqueue-get-itemdat      vec)    (vector-ref  vec 5))

(define-inline (tests:testqueue-set-testname!    vec val)(vector-set! vec 0 val))
(define-inline (tests:testqueue-set-testconfig!  vec val)(vector-set! vec 1 val))
(define-inline (tests:testqueue-set-waitons!     vec val)(vector-set! vec 2 val))
(define-inline (tests:testqueue-set-priority!    vec val)(vector-set! vec 3 val))
(define-inline (tests:testqueue-set-items!       vec val)(vector-set! vec 4 val))
(define-inline (tests:testqueue-set-itemdat!     vec val)(vector-set! vec 5 val))