Megatest

;;     (filedb:get-path db id)))

;; NB// #f => return dbdir only
;;      (was planned to be;  zeroth db with name=main.db)
;; 
;; If run-id is #f return to create and retrieve the path where the db will live.
;;

(define db:dbfile-path common:get-db-tmp-area)








(define (db:set-sync db)
  (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
    (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) 

;; open an sql database inside a file lock
;; returns: db existed-prior-to-opening

(define (db:sync-tables tbls last-update fromdb todb . slave-dbs)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
     (print-call-chain (current-error-port))
     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
     (debug:print 5 *default-log-port* "exn=" (condition->list exn))
     (debug:print 0 *default-log-port* " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
     (debug:print 0 *default-log-port* " src db:  " (db:dbdat-get-path fromdb))
     (for-each (lambda (dbdat)
		 (let ((dbpath (db:dbdat-get-path dbdat)))
		   (debug:print 0 *default-log-port* " dbpath:  " dbpath)
		   (if (not (db:repair-db dbdat))
		       (begin

	 (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
     (case err-status
       ((busy)
	(thread-sleep! sleep-time))
       (else
	(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
	(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	(debug:print 5 *default-log-port* "exn=" (condition->list exn))
	(debug:print 0 *default-log-port* " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
	(print-call-chain (current-error-port))
	(thread-sleep! sleep-time)
	(debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
     (apply open-run-close-exception-handling proc idb params))
   (apply open-run-close-no-exception-handling proc idb params)))

;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
;; if test-name is an integer work off that instead of test-name test-path
;;
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
  ;; establish info on incoming test followed by info on top level test
  ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
  
  (let* ((testdat      (if (number? test-name)
			   (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
			   (db:get-test-info       dbstruct run-id test-name item-path)))
	 (test-id      (db:test-get-id testdat))
	 (test-name    (if (number? test-name)
			   (db:test-get-testname testdat)
			   test-name))

                                                                                      *common:not-started-ok-statuses*))))
								  state-status-counts)))
                            ;; (non-completes        (filter (lambda (x)
                            ;;                                 (not (equal? (dbr:counts-state x) "COMPLETED")))
                            ;;                               state-status-counts))
                            (all-curr-states      (common:special-sort  ;; worst -> best (sort of)
                                                   (delete-duplicates
                                                    (if (not (equal? state "DELETED"))
                                                        (cons state (map dbr:counts-state state-status-counts))
                                                        (map dbr:counts-state state-status-counts)))
                                                   *common:std-states* >))
                            (all-curr-statuses    (common:special-sort  ;; worst -> best
                                                   (delete-duplicates
                                                    (if (not (equal? state "DELETED"))
                                                        (cons status (map dbr:counts-status state-status-counts))
                                                        (map dbr:counts-status state-status-counts)))
                                                   *common:std-statuses* >))
			    (non-completes     (filter (lambda (x)
							 (not (equal? x "COMPLETED")))
						       all-curr-states))
			    (num-non-completes (length non-completes))
                            
                            (newstate          (cond
						((> running 0)
						 "RUNNING") ;; anything running, call the situation running
						((> bad-not-started 0)  ;; we have an ugly situation, it is completed in the sense we cannot do more.
						 "COMPLETED") 
						((> num-non-completes 0) ;;
						 (car non-completes))  ;;  (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states)))
                                                ;; only rollup DELETED if all DELETED
						(else
						 (car all-curr-states))))
			                       ;; (if (> running 0)
                                               ;;     "RUNNING"
                                               ;;     (if (> bad-not-started 0)
                                               ;;         "COMPLETED"
                                               ;;         (car all-curr-states))))
                            (newstatus            (if (or (> bad-not-started 0)
							  (and (equal? newstate "NOT_STARTED")
							       (> num-non-completes 0)))
						      "STARTED"
                                                      (car all-curr-statuses))))
                       ;; (print "bad-not-supported: " bad-not-support " all-curr-states: " all-curr-states " all-curr-statuses: " all-curr-states)
                       ;;      " newstate: " newstate " newstatus: " newstatus)
                       ;; NB// Pass the db so it is part of the transaction
                       (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)))))))
         (mutex-unlock! *db-transaction-mutex*)
         (if (and test-id state status (equal? status "AUTO")) 
             (db:test-data-rollup dbstruct run-id test-id status))
         tr-res)))))
;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)
  (db:with-db
   dbstruct #f #f
   (lambda (db)
     (sqlite3:map-row
      (lambda (state status count)
	(make-dbr:counts state: state status: status count: count))

;; 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))
  ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items
  (append
   (if (member 'exclusive mode)
       (let ((running-tests (db:get-tests-for-run dbstruct
						  #f  ;; run-id of #f means for all runs. 
						  (if (string=? ref-item-path "")   ;; testpatt
						      ref-test-name
						      (conc ref-test-name "/" ref-item-path))

	    ;; 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) ;; BB- this is the upstream 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)) ;; BB- this is the upstream itempath
			(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)

		     (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 "") ;; if upstream rollup test is completed, parent-waiton-met is set
			      (or is-completed is-running));; this is the parent, set it to run if completed or running ;; BB1
			 (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)))))