Megatest

  (last-load-check-time    0)
  (last-jobs-check-time    0)
  )

(defstruct runs:testdat
  hed tal reg reruns  test-record
  test-name item-path jobgroup
  waitons testmode  newtal
  itemmaps
  (prereqs-not-met '())
  (last-update 0) ;; 
  )
  
;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files
;;  - remove any that are over 3600 seconds old
;;  - if there are any that are younger than 10 seconds
;;      * sleep 10 seconds
;;      * touch my key-host-pid.softlock file
;;      * return

;;    => review of a previously seen test is higher priority of never visited test
;; reg - list of previously visited tests
;; tal - list of never visited tests
;;   prefer next hed to be from reg than tal.

(define runs:nothing-left-in-queue-count 0)

(define (runs:lazy-get-prereqs-not-met  testdat run-id waitons hed item-path #!key (mode '(normal))(itemmaps #f)) ;; mode: testmode itemmaps: itemmaps)
  (if (< (- (current-seconds) (runs:testdat-last-update testdat)) 10) ;; only refresh for this test if it has been at least 10 seconds
      (begin
	;; (debug:print 0 *default-log-port* "last-update=" (runs:testdat-last-update testdat) "(current-seconds)=" (current-seconds))
	(runs:testdat-prereqs-not-met testdat))
      ;;                     (rmt:get-prereqs-not-met 46     '("r1") "y1" ""       mode: '(itemmatch) itemmaps: #f) 
      (let* ((res (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: mode         itemmaps: itemmaps)))
		    (debug:print 4 *default-log-port* "Get prereqs for " hed ", have " (length res)
				 " prereqs. last-update=" (runs:testdat-last-update testdat) " current-seconds=" (current-seconds)
				 " delta=" (- (current-seconds) (runs:testdat-last-update testdat)))
		    (if (list? res)
			res
			(begin
			  (debug:print 0 *default-log-port*
				       "ERROR: rmt:get-prereqs-not-met returned non-list!\n"
				       "  res=" res " run-id=" run-id " waitons=" waitons " hed=" hed
				       " item-path=" item-path " testmode=" mode " itemmaps=" itemmaps)
			  '())))))
	(runs:testdat-prereqs-not-met-set! testdat res)
	(runs:testdat-last-update-set! testdat (current-seconds))
	res)))
	   
;;======================================================================
;; runs:expand-items is called by runs:run-tests-queue
;;======================================================================
;;
;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
;;    (let loop ((hed         (car sorted-test-names))
;;	         (tal         (cdr sorted-test-names))
;;	         (reg         '()) ;; registered, put these at the head of tal 
;;	         (reruns      '()))
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record
			   can-run-more items runname tconfig reglen test-registry test-records itemmaps testdat)
  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
	  #;(let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)))
			    (if (list? res)
				res
				(begin
				  (debug:print 0 *default-log-port*
					       "ERROR: rmt:get-prereqs-not-met returned non-list!\n"
					       "  res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps)
				  '())))
	 (have-itemized   (not (null? (lset-intersection eq? testmode '(itemmatch itemwait)))))
	 ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
	 (fails           (runs:calc-fails prereqs-not-met))
	 (prereq-fails    (runs:calc-prereq-fail prereqs-not-met))
	 (non-completed   (runs:calc-not-completed prereqs-not-met))
	 (runnables       (runs:calc-runnable prereqs-not-met))
         (unexpanded-prereqs
          (filter (lambda (testname)

							  (conc run-id "," test-id) #f))
		    (test-name  (db:test-get-testname     testdat))
		    (item-path  (db:test-get-item-path    testdat))
		    (state      (db:test-get-state        testdat))
		    (status     (db:test-get-status       testdat))
		    (event-time (db:test-get-event_time   testdat))
		    (duration   (db:test-get-run_duration testdat)))
	       (if (and (not (member state '("DELETED" "REMOTEHOSTSTART" "RUNNING" "LAUNCHED" "LAUNCHING" "NOT_STARTED")))
			(not (and prevdat
				  (equal? state  (db:test-get-state  prevdat))
				  (equal? status (db:test-get-status prevdat)))))
		   (let ((fmt   (runs:gendat-inc-results-fmt *runs:general-data*))
			 (dtime (seconds->year-work-week/day-time event-time))) 
		     (if (runs:lownoise "inc-print" 600)
			 (format #t fmt "State" "Status" "Start Time" "Duration" "Test path"))

;; every time though the loop increment the test/itempatt val.
;; when the min is > max-allowed and none running then force exit
;;
(define *max-tries-hash* (make-hash-table))

(define (runs:pretty-long-list lst)
  (if (> (length lst) 8)(append (take lst 3)(list "...")) lst))

(define *runs-testdat-cache* (make-hash-table)) ;; full/testname => testdat

;;======================================================================
;; runs:run-tests-queue is called by runs:run-tests
;;======================================================================
;;
;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry)

				   extras)
				  extras)
				'())))
	     (waitons     (delete-duplicates (append (tests:testqueue-get-waitons test-record) extra-waits) equal?))
	     (newtal      (append tal (list hed)))
	     (regfull     (>= (length reg) reglen))
	     (num-running (rmt:get-count-tests-running-for-run-id run-id #t)) ;; fastmode=yes
	     (testdat     (let ((oldtestdat (hash-table-ref/default *runs-testdat-cache* tfullname #f)))
			    (if oldtestdat
				(begin
				  (runs:testdat-hed-set!         oldtestdat hed)
				  (runs:testdat-tal-set!         oldtestdat tal)
				  (runs:testdat-reg-set!         oldtestdat reg)
				  (runs:testdat-reruns-set!      oldtestdat reruns)
				  (runs:testdat-test-record-set! oldtestdat test-record)
				  (runs:testdat-newtal-set!      oldtestdat newtal)
				  
				  (if (not (equal? (runs:testdat-waitons oldtestdat) waitons))
				      (debug:print 0 *default-log-port* " waitons changed for runs:testdat"))
				  (if (not (equal? (runs:testdat-itemmaps oldtestdat) itemmaps))
				      (debug:print 0 *default-log-port* " itemmaps changed for runs:testdat"))
				  
				  oldtestdat)
				(let ((newtestdat (make-runs:testdat
						   hed: hed
						   tal: tal
						   reg: reg
						   reruns: reruns
						   test-record: test-record
						   test-name:   test-name
						   item-path:   item-path
						   jobgroup:    jobgroup
						   waitons:     waitons
						   testmode:    testmode
						   newtal:      newtal
						   itemmaps:    itemmaps
						   ;; prereqs-not-met: prereqs-not-met
						   )))
				  (hash-table-set! *runs-testdat-cache* tfullname newtestdat)
				  newtestdat)))))
	(runs:dat-regfull-set! runsdat regfull)
    
	(if (> num-running 0)
            (set! last-time-some-running (current-seconds)))

        (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000)))
            (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))

				  ;; wait for load here
				  (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
				  (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)
						     (- remtries 1)))))))
		       )))))

	  ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed
	  (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path
					 mode: testmode
					 itemmaps: itemmaps)

	  ;; I'm not clear on why we'd capture running job counts here TODO: verify this is needed
	  (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))

	  (let ((loop-list (runs:process-expanded-tests runsdat testdat))) ;; in process-expanded-tests ultimately run:test -> launch-test -> test actually running
            (if loop-list (apply loop loop-list))))

         
	 ;; 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
	 ;; EXPAND ITEMS
	 ((or (procedure? items)(eq? items 'have-procedure))
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-4")
	  (let ((can-run-more    #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
	    (if (not can-run-more) #;(and (list? can-run-more) ;; IDEA, this mechanism may have had some value, make it configurable to test pros/cons TODO
		(car can-run-more))
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps testdat))) ;; itemized test expanded here
		  (if loop-list
		      (apply loop loop-list)
                      (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed)
                      )
                  )
		;; if can't run more just loop with next possible test
		(loop (car newtal)(cdr newtal) reg reruns))))

	    (if (> (current-seconds)(+ last-time-incomplete 900))
		(let ((actual-num-running (rmt:get-count-tests-running-for-run-id run-id #f))) ;; fastmode=no
		  (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id
				    ". Running as pid " (current-process-id) " on " (get-host-name))
		  (set! last-time-incomplete (current-seconds)) ;; FIXME, this might be causing slow down - use of set!
		  (rmt:find-and-mark-incomplete run-id #f)
		  (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " actual-num-running
				    " tests in RUNNING, REMOTEHOSTSTART, LAUNCHING or LAUNCHED state at "
				    (time->string (seconds->local-time (current-seconds))))))
	    ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
	    (thread-sleep! 5) ;; (if (>= num-running max-concurrent-jobs) 5 1))
	    (wait-loop (rmt:get-count-tests-running-for-run-id run-id #t) ;; fastmode=yes
		       num-running))))
    ;; LET* ((test-record
    ;; we get here on "drop through". All done!

(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry runsdat testdat-rec)
  ;; All these vars might be referenced by the testconfig file reader
  ;; 
  ;; NEED to reprocess testconfig here, ensuring that item variables are available.
  ;; This is for Tal's issue with item-specific env vars not being set for use in skip.
  ;; HSD https://hsdes.intel.com/appstore/icf/index.html#/article?articleId=1408763273
  ;;
  (let* ((test-name       (tests:testqueue-get-testname   test-record))
	 (test-waitons    (tests:testqueue-get-waitons    test-record))
	 (itemdat         (or (tests:testqueue-get-itemdat test-record) '()))
	 (item-path       (item-list->path itemdat))

	 (full-test-name  (db:test-make-full-name test-name item-path))
	 (test-id         (rmt:get-test-id run-id test-name item-path)))

    ;; NOTE: Getting here does NOT mean that the test will be launched. 

    ;; setting itemdat to a list if it is #f



    (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process

    (let* ((test-conf ;; re-instate the tests:get-testconfig once the kinks are worked out. FIXME!!!
	    ;; (tests:get-testconfig test-name item-path all-tests-registry #t force-create: #t))
	    (tests:testqueue-get-testconfig test-record )) 
	   (test-path    (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...

	   (forceopt     (hash-table-ref/default flags "-force" #f))
	   (rerun        (hash-table-ref/default flags "-rerun" #f))
	   (keepgoing    (hash-table-ref/default flags "-keepgoing" #f))
	   (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x"))))
      

      (debug:print-info 4 *default-log-port*
			"\nTESTNAME: " full-test-name 
			"\n   test-config: " (hash-table->alist test-conf)
			"\n   itemdat: " itemdat
			)
      
      (debug:print 2 *default-log-port* "Attempting to launch test " full-test-name)



      (change-directory *toppath*)

      ;; Here is where the test_meta table is best updated
      ;; Yes, another use of a global for caching. Need a better way?
      ;;
      ;; There is now a single call to runs:update-all-test_meta and this 
      ;; per-test call is not needed. Given the delicacy of the move to 
      ;; v1.55 this code is being left in place for the time being.
      ;;
      (if (not (hash-table-ref/default *test-meta-updated* test-name #f))
	  (begin
	    (hash-table-set! *test-meta-updated* test-name #t)
	    (runs:update-test_meta test-name test-conf)))
      
      ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer"))
      (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
	     (test-id       (or test-id (rmt:get-test-id run-id test-name item-path)))
	     (testdat       (if test-id (rmt:get-test-info-by-id run-id test-id) #f)))
	(if (not testdat)
	    (let loop ()








	      (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path)))
	      (if (not test-id)
		  (begin
		    (debug:print 0 *default-log-port* "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
		    (rmt:register-test run-id test-name item-path)
		    (set! test-id (rmt:get-test-id run-id test-name item-path))))
	      (debug:print-info 4 *default-log-port* "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
	      (set! testdat (rmt:get-test-info-by-id run-id test-id))
	      (if (not testdat)
		  (begin
		    (debug:print-info 0 *default-log-port* "WARNING: server is overloaded, trying again in two seconds")
		    ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
		    (thread-sleep! 2)
		    (loop)))))
	(if (not testdat) ;; should NOT happen
	    (debug:print-error 0 *default-log-port* "failed to get test record for test-id " test-id))
	(set! test-id (db:test-get-id testdat))
	(if (common:file-exists? test-path)
	    (change-directory test-path)
	    (begin
	      (debug:print-error 0 *default-log-port* "test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?")
	      (change-directory *toppath*)))
	(case (if forceopt ;; (args:get-arg "-force")
		  'NOT_STARTED
		  (if testdat
		      (string->symbol (test:get-state testdat))
		      'failed-to-insert))
	  ((failed-to-insert)
	   (debug:print-error 0 *default-log-port* "Failed to insert the record into the db"))
	  ((NOT_STARTED COMPLETED DELETED INCOMPLETE)
	   (let ((runflag #f))
	     (cond
	      ;; -force, run no matter what
	      (force (set! runflag #t))
	      ;; NOT_STARTED, run no matter what
	      ((member (test:get-state testdat) '("DELETED" "NOT_STARTED" "INCOMPLETE"))(set! runflag #t))
	      ;; not -rerun and PASS, WARN or CHECK, do no run
	      ((and (or (not rerun)
			keepgoing)
		    ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK
		    (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED"))
			(member (test:get-state  testdat) '("COMPLETED")))) 
	       (debug:print-info 2 *default-log-port* "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat))
	       (hash-table-set! test-registry full-test-name 'DONOTRUN) ;; COMPLETED)
	       (set! runflag #f))
	      ;; -rerun and status is one of the specifed, run it
	      ((and rerun
		    (let* ((rerunlst   (string-split rerun ","))
			   (must-rerun (member (test:get-status testdat) rerunlst)))
		      (debug:print-info 3 *default-log-port* "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun)
		      must-rerun))
	       (debug:print-info 2 *default-log-port* "Rerun forced for test " test-name "/" item-path)
	       (set! runflag #t))
	      ;; -keepgoing, do not rerun FAIL
	      ((and keepgoing
		    (member (test:get-status testdat) '("FAIL")))
	       (set! runflag #f))
	      ((and (not rerun)
		    (member (test:get-status testdat) '("FAIL" "n/a")))
	       (set! runflag #t))
	      (else (set! runflag #f)))
	     (debug:print 4 *default-log-port* "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
	     (if (not runflag)
		 (if (not parent-test)
		     (if (runs:lownoise (conc "not starting test" full-test-name) 60)
			 (debug:print 1 *default-log-port* "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) 
				      "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat)
				      "\" or -force to override")))
		 ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are
		 ;;       already met.
		 ;; This would be a great place to do the process-fork
		 ;; 
		 (let ((skip-test   #f)
		       (skip-check  (configf:get-section test-conf "skip")))
		   (cond 
		    ;; Have to check for skip conditions. This one skips if there are same-named tests
		    ;; currently running
		    ((and skip-check
			  (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" "LAUNCHING" "LAUNCHED") '() #f)))
		       (if (not (null? running-tests)) ;; have to skip 
			   (set! skip-test "Skipping due to previous tests running"))))

 		    ;; split the string and OR of file-exists?
		    ((and skip-check
			  (configf:lookup test-conf "skip" "fileexists"))
		     (let* ((files    (string-split (configf:lookup test-conf "skip" "fileexists")))
			    (existing (filter common:file-exists? files)))
		       (if (not (null? existing)) ;; (common:file-exists? (configf:lookup test-conf "skip" "fileexists"))
			   (set! skip-test (conc "Skipping due to existance of file(s) " (string-intersperse existing ", ")))))) ;; (configf:lookup test-conf "skip" "fileexists")))))

 		    ((and skip-check
			  (configf:lookup test-conf "skip" "filenotexists"))
		     (let* ((files    (string-split (configf:lookup test-conf "skip" "filenotexists")))
			    (existing (filter common:file-exists? files)))
		       (if (null? existing) ;;  (common:file-exists? (configf:lookup test-conf "skip" "filenotexists")))
			   (set! skip-test (conc "Skipping due to non existance of files " (string-intersperse files ", ")))))) ;; (configf:lookup test-conf "skip" "filenotexists")))))        
		    
		    ((and skip-check
			  (configf:lookup test-conf "skip" "script"))
		     (if (= (system (configf:lookup test-conf "skip" "script")) 0)
			 (set! skip-test (conc "Skipping due to zero return value of script " (configf:lookup test-conf "skip" "script")))))
		    
		    ((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" "LAUNCHING" "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))
			    (time-since-last (- (current-seconds) (if (null? last-run-times) 0 (common:max last-run-times)))))
		       (if (or (not (null? running-tests)) ;; have to skip if test is running
			       (> numseconds time-since-last))
			   (set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago"))))))
		   
		   (if skip-test
		       (begin
			 (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test)
			 (debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test))
		       ;;
		       ;; Here the test is handed off to launch.scm for launch-test to complete the launch process
		       ;;
		       (begin
			 ;; first thing to do is to set the test to LAUNCHING to prevent or minimise
			 ;; races on exclusive mode and max_concurrent_jobs
			 (if (equal? (test:get-state testdat) "NOT_STARTED")
			     (rmt:test-set-state-status run-id test-id "LAUNCHING" "n/a" #f)
			     (debug:print 0 *default-log-port* "Odd, test " test-id " is in state " (test:get-state testdat) " yet we are trying to launch it."))
    
			 ;; wait for less than max jobs here
			 (if (runs:dat-wait-for-jobs-function runsdat)
			     ((runs:dat-wait-for-jobs-function runsdat) testdat-rec))
			 
			 (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
			     (begin
			       (print "ERROR: Failed to launch the test. Exiting as soon as possible")
			       (set! *globalexitstatus* 1) ;; 
			       (process-signal (current-process-id) signal/kill))
			     )
			 ;; wait again here?
			 ))))))
	  ((KILLED) 
	   (debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
	   (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED))
	  ((LAUNCHING LAUNCHED REMOTEHOSTSTART RUNNING)  
	   (debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))
	  ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
	  ;; 			       (db:test-get-run_duration testdat)))
	  ;; 	(or incomplete-timeout
	  ;; 	    6000)) ;; i.e. no update for more than 6000 seconds
	  ;;      (begin
	  ;;        (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
	  ;;        (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
	  ;;        ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
	  ;;      (debug:print 2 *default-log-port* "NOTE: " test-name " is already running")))
	  (else      
	   (debug:print-error 0 *default-log-port* "Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))
	   (case (string->symbol (test:get-state testdat)) 
	     ((COMPLETED INCOMPLETE)
	      (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN))
	     (else
	      (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)))))))))

;;======================================================================
;; END OF NEW STUFF
;;======================================================================

(define (get-dir-up-n dir . params) 
  (let ((dparts  (string-split dir "/"))

				      ) ; end case rem-status
                                    ) ; end let
                                  ); end cond has-subrun

                                 (else
                                  ;; BB - TODO - consider backgrounding to threads to delete tests (work below) 
                                  (debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state)
                                  (if (member test-state (list "RUNNING" "LAUNCHING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
                                      (begin
                                        (if (not (hash-table-ref/default test-retry-time test-fulln #f))
                                            (begin
                                              ;; want to set to REMOVING BUT CANNOT do it here?
                                              (hash-table-set! test-retry-time test-fulln (current-seconds))))
                                        (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time)
                                            ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first

                                      (if (not (null? tal))
                                         (loop (car tal)(cdr tal)))))))
				(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
                               ((kill-runs)
                                ;; RUNNING -> KILLREQ
                                ;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED
                                (cond
                                 ((and has-subrun (member test-state (list "RUNNING" "LAUNCHING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")))
                                  (common:send-thunk-to-background-thread
                                   (lambda ()
                                     (let* ((subrun-remove-succeeded
                                             (subrun:kill-subrun run-dir keep-records)))
                                       #t)))
                                  (if (not (null? tal))
				    (loop (car tal)(cdr tal)))

			 (test-state	(vector-ref test 3))
			 (comment	(vector-ref test 14))   
			 (test-status	(vector-ref test 4))
			 (exc-msg	(conc "No bucket for State " test-state " Status " test-status))
			 (new-doc	(cond 
						((member test-state (list "RUNNING" ))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
						((member test-state (list "LAUNCHING" "LAUNCHED" "REMOTEHOSTSTART"  "NOT_STARTED"))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
						((member test-status (list "PASS" "WARN" "WAIVED"))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
						((member test-status (list "FAIL" "CHECK"))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) 
						((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))