Megatest

;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
;; mode:
;;  'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states )
;;
(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)





  (let* ((qryvalstr       (case qryvals
			    ((shortlist) "id,run_id,testname,item_path,state,status")
			    ((#f)        db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
			    (else        qryvals)))
	 (res            '())
	 ;; if states or statuses are null then assume match all when not-in is false
	 (states-qry      (if (null? states) 
			      #f
			      (conc " state "  
				    (if (eq? mode 'dashboard)
					" IN ('"
					(if not-in
					    " NOT IN ('"
					    " IN ('")) 
				    (string-intersperse states   "','")
				    "')")))
	 (statuses-qry    (if (null? statuses)
			      #f
			      (conc " status "
				    (if (eq? mode 'dashboard)
					" IN ('"
					(if not-in 
					    " NOT IN ('"
					    " IN ('") )
				    (string-intersperse statuses "','")
				    "')")))
	 (interim-qry       (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ")
				  (if states-qry
				      (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ")
				      "")))
	 (states-statuses-qry 
	  (cond 
	   ((and states-qry statuses-qry)
	    (case mode
	      ((dashboard) 
	       (if not-in
		   (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) "
			 " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ")
		   (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) "
			 " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) ")))
	      (else       (conc " AND ( " states-qry " AND " statuses-qry " ) "))))
	   (states-qry  
	    (case mode
	      ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states    "','") "') ")) ;; interim-qry)
	      (else        (conc " AND " states-qry))))
	   (statuses-qry 
	    (case mode
	      ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry)
	      (else        (conc " AND " statuses-qry))))
	   (else "")))
	 (tests-match-qry (tests:match->sqlqry testpatt))
	 (qry             (conc "SELECT " qryvalstr
				(if run-id
				    " FROM tests WHERE run_id=? "
				    " FROM tests WHERE ? > 0 ") ;; should work?
				(if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests?
				states-statuses-qry
				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
				(if last-update (conc " AND last_update >= " last-update " ") "")
				(case sort-by
				  ((rundir)      " ORDER BY length(rundir) ")
				  ((testname)    (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
				  ((statestatus) (conc " ORDER BY state " (if  sort-order (conc sort-order ",") "") " status "))
				  ((event_time)  " ORDER BY event_time ")
				  (else          (if (string? sort-by)
						     (conc " ORDER BY " sort-by " ")
						     " ")))
				(if sort-order sort-order " ")
				(if limit  (conc " LIMIT " limit)   " ")
				(if offset (conc " OFFSET " offset) " ")
				";"
				)))
    (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
    (db:with-db dbstruct run-id #f
		(lambda (db)
		  (sqlite3:for-each-row 
		   (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
		     (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
		   db
		   qry
		   (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs
		   )))
    (case qryvals
      ((shortlist)(map db:test-short-record->norm res))
      ((#f)       res)
      (else       res))))

(define (db:test-short-record->norm inrec)
  ;;  "id,run_id,testname,item_path,state,status"
  ;;  "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
  (vector (vector-ref inrec 0) ;; id
	  (vector-ref inrec 1) ;; run_id
	  (vector-ref inrec 2) ;; testname

;; 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: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;;       mode 'toplevel means that tests must be COMPLETED only
;;       mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;;       mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING
;; 
;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
(define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f))
  (if (eq? mode 'exclusive)
      (let ((running-tests (db:get-tests-for-run dbstruct
						 #f  ;; run-id of #f means for all runs. 
						 (if (string=? ref-item-path "")
						     ref-test-name
						     (conc ref-test-name "/" ref-item-path))
						 '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING")
						 '()
						 #f
						 #f
						 'shortlist
						 0 ;; last update, beginning of time ....
						 #f)))
	running-tests)
      (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
	       ;; next should be using mt:get-tests-for-run?
	       (let ((tests             (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
		     (ever-seen         #f)
		     (parent-waiton-met #f)
		     (item-waiton-met   #f))
		 (for-each 
		  (lambda (test)
		    ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ...
		    (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-running        (equal? state "RUNNING"))
			   (is-killed         (equal? state "KILLED"))
			   (is-ok             (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))
			   ;;                                       testname-b    path-a    path-b
			   (same-itempath     (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (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 of the waiton being examined
			     is-completed
			     (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;;  itemmatch itemwait))))))
			(set! parent-waiton-met #t))
		       ;; Special case for toplevel and KILLED
		       ((and (equal? item-path "") ;; this is the parent test
			     is-killed
			     (member 'toplevel mode))
			(set! parent-waiton-met #t))
		       ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
		       ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ?????
			     ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items
			     same-itempath)
			(if (and is-completed is-ok)
			    (set! item-waiton-met #t))
			(if (and (equal? item-path "")
				 (or is-completed is-running));; this is the parent, set it to run if completed or running
			    (set! parent-waiton-met #t)))
		       ;; normal checking of parent items, any parent or parent item not ok blocks running
		       ((and is-completed
			     (or is-ok 
				 (member 'toplevel mode))              ;; toplevel does not block on FAIL
			     (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok
			(set! item-waiton-met #t)))))
		  tests)
		 ;; both requirements, parent and item-waiton must be met to NOT add item to
		 ;; prereq's not met list
		 (if (not (or parent-waiton-met item-waiton-met))
		     (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 (if (null? tests)(list waitontest-name) tests) result)))))
	     waitons)
	    (delete-duplicates result)))))

;;======================================================================
;; Just for sync, procedures to make sync easy
;;======================================================================

;; get an alist of record ids changed since time since-time
;;   '((runs . (1 2 3 ...))(steps . (5 6 7 ...) ...))

	 (for-each
	  (lambda (runkey)
	    (let* ((keydats   (configf:get-section rgconf runkey)))
	      (for-each
	       (lambda (sense) ;; these are the sense rules
		 (let* ((key        (car sense))
			(val        (cadr sense))
			(keyparts   (string-split key ":")) ;; contour:ruletype:action:optional
			(contour    (car keyparts))
			(len-key    (length keyparts))
			(ruletype   (if (> len-key 1)(cadr keyparts) #f))
			(action     (if (> len-key 2)(caddr keyparts) #f))
			(optional   (if (> len-key 3)(cadddr keyparts) #f))
			;; (val-list   (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
			(val-alist  (val->alist val))
			(runname    (make-runname "" ""))
			(runtrans   (alist-ref 'runtrans val-alist))
			
			(runstarts  (find-pkts pdb '(runstart) `((o . ,contour)
								 (t . ,runkey))))

				 (if need-run
				     (let* ((key-msg    `((message  . ,(conc ruletype ":" message))
							  (runname  . ,runname)
							  (runtrans . ,runtrans)
							  (action   . ,action)
							  (target   . ,new-target))))
				       (print "key-msg: " key-msg)
				       (push-run-spec torun contour
						      (if optional  ;; we need to be able to differentiate same contour, different behavior. 
							  (conc runkey ":" optional)  ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
							  runkey)
						      key-msg)))))))
		       val-alist)) ;; iterate over the param split by ;\s*

		     ((fossil)
		      (for-each
		       (lambda (fspec)
			 (print "fspec: " fspec)
			 (let* ((url         (symbol->string (car fspec))) ;; THIS COULD BE TROUBLE. Add option to reading line to return as string.

			(configf:lookup test-conf "skip" "prevrunning"))
		   ;; run-ids = #f means *all* runs
		   (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)))
		     (if (not (null? running-tests)) ;; have to skip 
			 (set! skip-test "Skipping due to previous tests running"))))
		  ((and skip-check
			(configf:lookup test-conf "skip" "fileexists"))
		   (if (common:file-exists? (configf:lookup test-conf "skip" "fileexists"))
		       (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))

		  ((and skip-check
			(configf:lookup test-conf "skip" "rundelay"))
		   ;; run-ids = #f means *all* runs
		   (let* ((numseconds      (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay")))
			  (running-tests   (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))
			  (completed-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("COMPLETED" "INCOMPLETE") '("PASS" "FAIL" "ABORT") #f)) ;; ironically INCOMPLETE is same as COMPLETED in this contex
			  (last-run-times  (map db:mintest-get-event_time completed-tests))