Megatest

Diff
Login

Differences From Artifact [b407faba37]:

To Artifact [6f1beb94af]:


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
	  (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)) ;; itemdat can be a string, list or #f
		 (items       (tests:testqueue-get-items      test-record))
		 (item-path   (item-list->path itemdat))
		 (newtal      (append tal (list hed))))







	    (debug:print 6
			 "itemdat:     " itemdat
			 "\n  items:     " items
			 "\n  item-path: " item-path)
	    (cond
	     ((not items) ;; when false the test is ok to be handed off to launch (but not before)
	      (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)))


		;; Don't know at this time if the test have been launched at some time in the past
		;; i.e. is this a re-launch?
		(cond
		 ((and have-resources
		       (null? prereqs-not-met))
		  ;; no loop here, just drop though and use the loop at the bottom 
		  (if (patt-list-match item-path item-patts)
		      (run:test db run-id runname keyvallst test-record flags #f)
		      (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts))
		  ;; else the run is stuck, temporarily or permanently
		  ;; but should check if it is due to lack of resources vs. prerequisites
		  )
		 ((not have-resources) ;; simply try again after waiting a second
		  (thread-sleep! 1.0)
		  (debug:print 1 "INFO: no resources to run new tests, waiting ...")
		  ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
		  (loop (car newtal)(cdr newtal)))
		 (else ;; must be we have unmet prerequisites
		  (let ((fails  (filter (lambda (test)
					  (and (not (string? test))
					       (not (member (db:test-get-status test)
							    '("PASS" "WARN" "CHECK" "WAIVED")))))
					prereqs-not-met)))
		    (debug:print 4 "FAILS: " fails)
		    ;; If one or more of the prereqs-not-met are FAIL then we can issue
		    ;; a message and drop hed from the items to be processed.
		    (if (null? fails)
			(begin
			  ;; couldn't run, take a breather
			  (debug:print 4 "INFO: Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...")
			  (thread-sleep! 0.1) ;; long sleep here - no resources, may as well be patient
			  ;; we made new tal by sticking hed at the back of the list
			  (loop (car newtal)(cdr newtal)))
			;; the waiton is FAIL so no point in trying to run hed ever again
			(if (not (null? tal))
			    (begin
			      (debug:print 1 "WARN: Dropping test " (db:test-get-test-name hed) "/" (db:test-get-item-path hed)
					   " from the launch list as it has prerequistes that are FAIL")
			      (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 (and (>= *verbosity* 1)
		       (> (length items) 0)
		       (> (length (car items)) 0))







|
>
>
>
>
>
>
>






|
|
|
>


















<
<
<
<
<















|







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
	  (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)) ;; itemdat can be a string, list or #f
		 (items       (tests:testqueue-get-items      test-record))
		 (item-path   (item-list->path itemdat))
		 (newtal      (append tal (list hed)))
		 (calc-fails  (lambda (prereqs-not-met)
				(filter (lambda (test)
					  (debug:print 9 "test: " test)
					  (and (vector? test) ;; not (string? test))
					       (not (member (db:test-get-status test)
							    '("PASS" "WARN" "CHECK" "WAIVED")))))
					prereqs-not-met))))
	    (debug:print 6
			 "itemdat:     " itemdat
			 "\n  items:     " items
			 "\n  item-path: " item-path)
	    (cond
	     ((not items) ;; when false the test is ok to be handed off to launch (but not before)
	      (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))
		     (fails           (calc-fails prereqs-not-met)))
		(debug:print 8 "INFO: have-resources: " have-resources " prereqs-not-met: " prereqs-not-met " fails: " fails)
		;; Don't know at this time if the test have been launched at some time in the past
		;; i.e. is this a re-launch?
		(cond
		 ((and have-resources
		       (null? prereqs-not-met))
		  ;; no loop here, just drop though and use the loop at the bottom 
		  (if (patt-list-match item-path item-patts)
		      (run:test db run-id runname keyvallst test-record flags #f)
		      (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts))
		  ;; else the run is stuck, temporarily or permanently
		  ;; but should check if it is due to lack of resources vs. prerequisites
		  )
		 ((not have-resources) ;; simply try again after waiting a second
		  (thread-sleep! 1.0)
		  (debug:print 1 "INFO: no resources to run new tests, waiting ...")
		  ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
		  (loop (car newtal)(cdr newtal)))
		 (else ;; must be we have unmet prerequisites





		    (debug:print 4 "FAILS: " fails)
		    ;; If one or more of the prereqs-not-met are FAIL then we can issue
		    ;; a message and drop hed from the items to be processed.
		    (if (null? fails)
			(begin
			  ;; couldn't run, take a breather
			  (debug:print 4 "INFO: Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...")
			  (thread-sleep! 0.1) ;; long sleep here - no resources, may as well be patient
			  ;; we made new tal by sticking hed at the back of the list
			  (loop (car newtal)(cdr newtal)))
			;; the waiton is FAIL so no point in trying to run hed ever again
			(if (not (null? tal))
			    (begin
			      (debug:print 1 "WARN: Dropping test " (db:test-get-test-name hed) "/" (db:test-get-item-path hed)
					   " from the launch list as it has prerequistes that are FAIL")
			      (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 (and (>= *verbosity* 1)
		       (> (length items) 0)
		       (> (length (car items)) 0))
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
	       items)
	      (if (not (null? tal))
		  (loop (car tal)(cdr tal))))

	     ;; if items is a proc then need to run items:get-items-from-config, get the list and loop 
	     ;;    - but only do that if resources exist to kick off the job
	     ((or (procedure? items)(eq? items 'have-procedure))
	      (let ((can-run-more    (runs:can-run-more-tests db test-record))
		    (prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path)))





		(if (and can-run-more (null? prereqs-not-met))
		    (let ((test-name (tests:testqueue-get-testname test-record)))
		      (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
		      (let ((items-list (items:get-items-from-config tconfig)))
			(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)))))
		    (if can-run-more
			(loop (car newtal)(cdr newtal)) ;; an issue with prereqs not yet met?
			(begin
			  (debug:print 1 "INFO: Can't run more right now, killing a little time ...")
			  (thread-sleep! 1.0)
			  (loop (car newtal)(cdr newtal)))))))
			
		    ;; Can't run anything right now so put the test back on the queue
		    ;; (let ((newtal (append tal (list hed)))
		    ;;       (fails  (filter (lambda (test)  ;; fails is a list of prerequisite tests that are FAIL
		    ;;     		    (not (member (db:test-get-status test)
		    ;;     				 '("PASS" "WARN" "CHECK" "WAIVED"))))
		    ;;     		  prereqs-not-met)))
		    ;;   ;; if can't run more tests, lets take a breather
		    ;;   (debug:print 4 "FAILS: " fails)
		    ;;   ;; If one or more of the prereqs-not-met are FAIL then we can issue
		    ;;   ;; a message and drop hed from the items to be processed.
		    ;;   (if (null? fails)
		    ;;       (begin
		    ;;         ;; couldn't run, take a breather
		    ;;         (thread-sleep! 0.1) ;; long sleep here - no resources, may as well be patient
		    ;;         (loop (car newtal)(cdr newtal)))
		    ;;       ;; the waiton is FAIL so no point in trying to run hed

		    ;;       (if (not (null? tal))
		    ;;           (loop hed tal)))))))

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







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







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
	       items)
	      (if (not (null? tal))
		  (loop (car tal)(cdr tal))))

	     ;; if items is a proc then need to run items:get-items-from-config, get the list and loop 
	     ;;    - but only do that if resources exist to kick off the job
	     ((or (procedure? items)(eq? items 'have-procedure))
	      (let* ((can-run-more    (runs:can-run-more-tests db test-record))
		     (prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path))
		     (fails           (calc-fails prereqs-not-met)))
		(debug:print 8 "INFO: can-run-more: " can-run-more
			     " prereqs-not-met:\n  " (intersperse prereqs-not-met "\n")
			     " fails:\n "            (intersperse fails "\n"))
		(cond 
		 ((and can-run-more (null? prereqs-not-met))
		  (let ((test-name (tests:testqueue-get-testname test-record)))
		    (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
		    (let ((items-list (items:get-items-from-config tconfig)))
		      (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))))))
		 ((and can-run-more (null? fails))


		  (debug:print 4 "INFO: Can't run more right now, killing a little time ...")
		  (thread-sleep! 3.0)
		  (loop (car newtal)(cdr newtal))) ;; an issue with prereqs not yet met?
		 (else







		  (debug:print 1 "INFO: test "  hed " has failed prerequisite(s); "


			       (string-intersperse (map db:test-get-testname fails) ", ")





			       ", removing it from to-do list")
		  (if (not (null? tal))
		      (loop (car tal)(cdr tal)))))))
	     
	     ;; 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)
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
	    ((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)
		  ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK
		  (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK"))
		      (member (test:get-state  testdat) '("COMPLETED")))) 
	     (debug:print 2 "INFO: running test " test-name "/" item-path " suppressed as it is COMPLETED and " (test:get-state testdat))
	     (set! runflag #f))
	    ;; -rerun and status is one of the specifed, run it
	    ((and rerun
		  (let* ((rerunlst   (string-split rerun ","))
			 (must-rerun (member (test:get-status testdat) rerunlst)))
		    (debug:print 3 "INFO: -rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun)
		    must-rerun))







|







480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
	    ((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)
		  ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK
		  (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK"))
		      (member (test:get-state  testdat) '("COMPLETED")))) 
	     (debug:print 2 "INFO: running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat))
	     (set! runflag #f))
	    ;; -rerun and status is one of the specifed, run it
	    ((and rerun
		  (let* ((rerunlst   (string-split rerun ","))
			 (must-rerun (member (test:get-status testdat) rerunlst)))
		    (debug:print 3 "INFO: -rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun)
		    must-rerun))