Megatest

Diff
Login

Differences From Artifact [13613d1781]:

To Artifact [13028d0fd1]:


385
386
387
388
389
390
391

392
393
394
395
396

397
398
399
400
401
402
403
		;; 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
		 ((not (patt-list-match item-path item-patts))
		  ;; else the run is stuck, temporarily or permanently
		  ;; but should check if it is due to lack of resources vs. prerequisites
		  (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts)

		  (if (not (null? tal))
		      (loop (car tal)(cdr tal) reruns)))
		 ((not (hash-table-ref/default test-registery (conc test-name "/" item-path) #f))
		  (open-run-close db:tests-register-test #f run-id test-name item-path)
		  (hash-table-set! test-registery (conc test-name "/" item-path) #t)

		  (loop (car newtal)(cdr newtal) reruns))
		 ((not have-resources) ;; simply try again after waiting a second
		  (thread-sleep! (+ 1 *global-delta*))
		  (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) reruns))
		 ((and have-resources







>





>







385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
		;; 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
		 ((not (patt-list-match item-path item-patts))
		  ;; else the run is stuck, temporarily or permanently
		  ;; but should check if it is due to lack of resources vs. prerequisites
		  (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts)
		  (thread-sleep! *global-delta*)
		  (if (not (null? tal))
		      (loop (car tal)(cdr tal) reruns)))
		 ((not (hash-table-ref/default test-registery (conc test-name "/" item-path) #f))
		  (open-run-close db:tests-register-test #f run-id test-name item-path)
		  (hash-table-set! test-registery (conc test-name "/" item-path) #t)
		  (thread-sleep! *global-delta*)
		  (loop (car newtal)(cdr newtal) reruns))
		 ((not have-resources) ;; simply try again after waiting a second
		  (thread-sleep! (+ 1 *global-delta*))
		  (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) reruns))
		 ((and have-resources
418
419
420
421
422
423
424

425
426
427

428
429
430
431
432
433
434
			  ;; we made new tal by sticking hed at the back of the list
			  (loop (car newtal)(cdr newtal) reruns))
			;; the waiton is FAIL so no point in trying to run hed ever again
			(if (not (null? tal))
			    (if (vector? hed)
				(begin (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed)
						    " from the launch list as it has prerequistes that are FAIL")

				       (loop (car tal)(cdr tal) (cons hed reruns)))
				(begin
				  (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;;  " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")

				  (loop hed tal reruns)))))))))
	     
	     ;; 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)







>



>







420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
			  ;; we made new tal by sticking hed at the back of the list
			  (loop (car newtal)(cdr newtal) reruns))
			;; the waiton is FAIL so no point in trying to run hed ever again
			(if (not (null? tal))
			    (if (vector? hed)
				(begin (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed)
						    " from the launch list as it has prerequistes that are FAIL")
				       (thread-sleep! *global-delta*)
				       (loop (car tal)(cdr tal) (cons hed reruns)))
				(begin
				  (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;;  " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
				  (thread-sleep! *global-delta*)
				  (loop hed tal reruns)))))))))
	     
	     ;; 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)
449
450
451
452
453
454
455


456
457
458
459
460
461
462
463
			 (tests:testqueue-set-items!     new-test-record #f)
			 (tests:testqueue-set-itemdat!   new-test-record my-itemdat)
			 (tests:testqueue-set-item_path! new-test-record my-item-path)
			 (hash-table-set! test-records newtestname new-test-record)
			 (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath
	       items)
	      (if (not (null? tal))


		  (loop (car tal)(cdr tal) reruns)))

	     ;; 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    (open-run-close runs:can-run-more-tests #f test-record)))
		(if can-run-more
		    (let* ((prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode))







>
>
|







453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
			 (tests:testqueue-set-items!     new-test-record #f)
			 (tests:testqueue-set-itemdat!   new-test-record my-itemdat)
			 (tests:testqueue-set-item_path! new-test-record my-item-path)
			 (hash-table-set! test-records newtestname new-test-record)
			 (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath
	       items)
	      (if (not (null? tal))
		  (begin
		    (thread-sleep! *global-delta*)
		    (loop (car tal)(cdr tal) reruns))))

	     ;; 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    (open-run-close runs:can-run-more-tests #f test-record)))
		(if can-run-more
		    (let* ((prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode))
482
483
484
485
486
487
488

489
490
491
492
493
494

495
496
497
498
499
500


501
502
503
504
505
506
507
508

509
510
511
512
513
514
515
			  (setenv "MT_TEST_NAME" test-name) ;; 
			  (setenv "MT_RUNNAME"   runname)
			  (open-run-close set-megatest-env-vars #f 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 reruns))
				(begin
				  (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
				  (exit 1))))))
		       ((null? fails)
			(debug:print 4 "INFO: fails is null, moving on in the queue but keeping " hed " for now")

			(loop (car newtal)(cdr newtal) reruns)) ;; an issue with prereqs not yet met?
		       ((and (not (null? fails))(eq? testmode 'normal))
			(debug:print 1 "INFO: test "  hed " (mode=" testmode ") has failed prerequisite(s); "
				     (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
				     ", removing it from to-do list")
			(if (not (null? tal))


			    (loop (car tal)(cdr tal)(cons hed reruns))))
		       (else
			(debug:print 8 "ERROR: No handler for this condition.")
			;; 	     "\n  hed:            " hed 
			;; 	     "\n fails:           " (string-intersperse (map db:test-get-testname fails) ",")
			;; 	     "\n testmode:        " testmode
			;; 	     "\n prereqs-not-met: " (pretty-string prereqs-not-met)
			;; 	     "\n items:           " items)

			(loop (car newtal)(cdr newtal) reruns))))
		    ;; if can't run more just loop with next possible test
		    (begin
		      (debug:print 4 "INFO: processing the case with a lambda for items or 'have-procedure. Moving through the queue without dropping " hed)
		      (thread-sleep! (+ 1 *global-delta*))
		      (loop (car newtal)(cdr newtal) reruns)))))
	     







>






>






>
>
|







>







488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
			  (setenv "MT_TEST_NAME" test-name) ;; 
			  (setenv "MT_RUNNAME"   runname)
			  (open-run-close set-megatest-env-vars #f 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)
				  (thread-sleep! *global-delta*)
				  (loop hed tal reruns))
				(begin
				  (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
				  (exit 1))))))
		       ((null? fails)
			(debug:print 4 "INFO: fails is null, moving on in the queue but keeping " hed " for now")
			(thread-sleep! *global-delta*)
			(loop (car newtal)(cdr newtal) reruns)) ;; an issue with prereqs not yet met?
		       ((and (not (null? fails))(eq? testmode 'normal))
			(debug:print 1 "INFO: test "  hed " (mode=" testmode ") has failed prerequisite(s); "
				     (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
				     ", removing it from to-do list")
			(if (not (null? tal))
			    (begin
			      (thread-sleep! *global-delta*)
			      (loop (car tal)(cdr tal)(cons hed reruns)))))
		       (else
			(debug:print 8 "ERROR: No handler for this condition.")
			;; 	     "\n  hed:            " hed 
			;; 	     "\n fails:           " (string-intersperse (map db:test-get-testname fails) ",")
			;; 	     "\n testmode:        " testmode
			;; 	     "\n prereqs-not-met: " (pretty-string prereqs-not-met)
			;; 	     "\n items:           " items)
			(thread-sleep! *global-delta*)
			(loop (car newtal)(cdr newtal) reruns))))
		    ;; if can't run more just loop with next possible test
		    (begin
		      (debug:print 4 "INFO: processing the case with a lambda for items or 'have-procedure. Moving through the queue without dropping " hed)
		      (thread-sleep! (+ 1 *global-delta*))
		      (loop (car newtal)(cdr newtal) reruns)))))