Megatest

Check-in [6c65b71621]
Login
Overview
Comment:Rework of runs proceeding... it now compiles
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | reorg-runs-code
Files: files | file ages | folders
SHA1: 6c65b7162126bbdb25b025607ae7a872995236cb
User & Date: matt on 2011-11-25 23:06:02
Other Links: branch diff | manifest | tags
Context
2011-11-26
09:50
Got items back check-in: 6fddca5ea1 user: matt tags: reorg-runs-code
2011-11-25
23:06
Rework of runs proceeding... it now compiles check-in: 6c65b71621 user: matt tags: reorg-runs-code
2011-11-24
13:02
Infintesimal changes for the runs rework check-in: 994d8ad82a user: matt tags: reorg-runs-code
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

PREFIX=.


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

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
runs.o : old-runs.scm test_records.scm

$(OFILES) $(GOFILES) : common_records.scm 

%.o : %.scm
	csc -c $<

$(PREFIX)/bin/megatest : megatest
	@echo Installing to PREFIX=$(PREFIX)
	cp megatest $(PREFIX)/bin/megatest

$(HELPERS) : utils/mt_* 
	cp $< $@


>
















|





|
|
|
|





|







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 $(CSCOPTS) $(OFILES) megatest.o -o megatest

dboard : $(OFILES) $(GOFILES)
	csc $(OFILES) $(GOFILES) -o dboard

# Special dependencies for the includes
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 $(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
		  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 '())
	     (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







|
>
|







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 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
		       (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))
		   ((and same-itempath
			 is-completed
			 is-ok)
		    (set! item-waiton-met #t)))))
	      tests)
	     (if (not (or 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)
      (delete-duplicates result))))

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

;; runspatt is a comma delimited list of run patterns







|





|



|







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! parent-waiton-met #t))
		   ((and same-itempath
			 is-completed
			 is-ok)
		    (set! item-waiton-met #t)))))
	      tests)
	     (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)))))
	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

(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)

  (string-intersperse  (map cadr itemdat) "/"))









>
|
>

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) "/")
      ""))

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

;; 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)))))

;;======================================================================
;; Rollup into a run
;;======================================================================
(if (args:get-arg "-rollup")
    (general-run-call 
     "-rollup" 







|
>
>
>
>
|
>
>
>
|
>
>
>
>
|







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
	      (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
     (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 ","))

     ;; 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







|







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)))))
     (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
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
	(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)))








	    (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)))

(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)))
	  (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)))
	      (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"))







|
>
>
>
>
>
>
>
>














|

|


>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|


<

<
<
<
<







>
>
>
>
>
>
>
>
>
>
>












<







215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
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
	(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     ;; 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 db run-id runname test-records keyvallst flags)))

(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-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 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
		  (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)

  ;; All these vars might be referenced by the testconfig file reader




  (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)

      (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
	     (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...







|







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 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
	  (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)))

	 (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







>







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
(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")



(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 













>







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
			     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"))))











	 (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))
	     #f ;; cannot have a which is waiting on b happening before b
	     (if (and b-waiton (member? (tests:testqueue-get-testname a) 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))))))))


;;======================================================================







|
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>


|

|







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 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-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-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))))))))


;;======================================================================