Megatest

;; 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
;;
;; Note: do not convert to remote as it calls remote under the hood
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK or WAIVED)
;;       mode 'toplevel means that tests must be COMPLETED only
;;
(define (db:get-prereqs-not-met db run-id waitons ref-item-path)
;; 
(define (db:get-prereqs-not-met db run-id waitons ref-item-path #!key (mode 'normal))
  (if (or (not waitons)
	  (null? waitons))
      '()
      (let* ((unmet-pre-reqs '())
	     (result         '()))
	(for-each 
	 (lambda (waitontest-name)

		       (is-ok             (member status '("PASS" "WARN" "CHECK" "WAIVED")))
		       (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)
			 (or is-ok (eq? mode 'toplevel)))
		    (set! parent-waiton-met #t))
		   ((and same-itempath
			 is-completed
			 is-ok)
			 (or is-ok (eq? mode 'toplevel)))
		    (set! item-waiton-met #t)))))
	      tests)
	     (if (not (or parent-waiton-met item-waiton-met))
		 (set! result (append tests result)))
		 (set! result (append (if (null? tests) (list waitontest-name) tests) result)))
	     ;; if the test is not found then clearly the waiton is not met...
	     ;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
	     (if (not ever-seen)(set! result (append tests result)))))
	     (if (not ever-seen)
		 (set! result (append (if (null? tests)(list waitontest-name) tests) result)))))
	waitons)
      (delete-duplicates result))))

(define (db:teststep-set-status! db test-id teststep-name state-in status-in item-path comment logfile)
  (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name)
  (let* ((state     (check-valid-items "state" state-in))
	 (status    (check-valid-items "status" status-in)))

(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 " flags: " (hash-table->alist flags))
  (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records))
	(item-patts        (hash-table-ref/default flags "-itempatt" #f)))
    (if (not (null? sorted-test-names))
	(let loop (; (numtimes 0) ;; shouldn't need this
		   (hed         (car sorted-test-names))
	(let loop ((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)) ;; itemdat can be a string, list or #f
		 (items       (tests:testqueue-get-items      test-record))
		 (item-path   (item-list->path itemdat)))
		 (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
		(if (and have-resources
			 (null? prereqs-not-met))
		    ;; no loop - 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
		    (let ((newtal (append tal (list hed)))
			  (fails  (filter (lambda (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
			    (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 (car tal)(cdr tal))))))))
		 ((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))

			(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)
					    (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 (car tal)(cdr tal))))))))
		    ;; (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

		'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

(hash-table-set! args:arg-hash ":runname" "rollup")

(test "Remove the rollup run" #t (begin (remove-runs) #t))
(test "Rollup the run(s)" #t (begin
			       (runs:rollup-run db keys)
			       #t))

;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal)
;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '())