Megatest

;; WARNING: Do NOT call this for the parent test on an iterated test
;; Roll up test_data pass/fail results
;; look at the test_data status field, 
;;    if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
;;    if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
(define (db:test-data-rollup db test-id status)
  (let ((tdb (open-run-close db:open-test-db-by-test-id db test-id))
	(fail-count 0)
	(pass-count 0))
    (if tdb
	(begin
	  (sqlite3:for-each-row
	   (lambda (fcount pcount)
	     (set! fail-count fcount)
	     (set! pass-count pcount))
	   tdb 
	   "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
                   (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
	   test-id test-id)
	  (sqlite3:finalize! tdb)

	  ;; Now rollup the counts to the central megatest.db
	  (rdb:pass-fail-counts test-id fail-count pass-count)
	  ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;" 
	  ;;                     fail-count pass-count test-id)

	  (thread-sleep! 0.01) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set
	  
	  ;; if the test is not FAIL then set status based on the fail and pass counts.
	  (rdb:test-rollup-iterated-pass-fail test-id)
	  ;; (sqlite3:execute
	  ;;  db   ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME
	  ;;  "UPDATE tests
          ;;             SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 

	(apply (rpc:procedure 'rdb:open-run-close host port) procname remargs))
      (apply open-run-close (eval procname) remargs)))

(define (rdb:test-set-status-state test-id status state msg)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	(handle-exceptions
	 exn
	 (begin
	   (debug:print 0 "EXCEPTION: rpc call failed?")
	   (debug:print 0 "  " ((condition-property-accessor 'exn 'message) exn))
	   (print-call-chain)
	   (cdb:test-set-status-state test-id status state msg))
	 ((rpc:procedure 'cdb:test-set-status-state host port) test-id status state msg)))
      (cdb:test-set-status-state test-id status state msg)))

(define (rdb:test-rollup-iterated-pass-fail test-id)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'cdb:test-rollup-iterated-pass-fail host port) test-id))