Megatest

				   (lambda (a b)
				     (< (hash-table-ref all-files a)(hash-table-ref all-files b))))
			     (- num-logs max-allowed))))
	    (for-each
	     (lambda (file)
	       (let* ((fullname (conc "logs/" file)))
		 (if (directory? fullname)
		     (debug:print-info 0 *default-log-port* fullname " in logs directory is a directory! Cannot rotate it, it is best to not put subdirectories in the logs dir.")
		     (handle-exceptions
		      exn
		      (debug:print-error 0 *default-log-port* "failed to remove " fullname ", exn=" exn)
		      (delete-file* fullname)))))
	     files)
	    (debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files."))))))
  

    (2 "KILLREQ")
    (3 "KILLED")
    (4 "NOT_STARTED")
    (5 "COMPLETED")
    (6 "LAUNCHED")
    (7 "REMOTEHOSTSTART")
    (8 "RUNNING")
    (9 "LAUNCHING")
    ))

(define *common:dont-roll-up-states*
  '("DELETED"
    "REMOVING"
    "CLEANING"
    "ARCHIVE_REMOVING"

  '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD"))

(define *common:well-ended-states* ;; an item's prereq in this state allows item to proceed
  '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))

;; BBnote: *common:running-states* used from db:set-state-status-and-roll-up-items
(define *common:running-states*     ;; test is either running or can be run
  '("RUNNING" "REMOTEHOSTSTART" "LAUNCHING" "LAUNCHED" "STARTED"))

(define *common:cant-run-states*    ;; These are stopping conditions that prevent a test from being run
  '("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED"))

(define *common:not-started-ok-statuses* ;; if not one of these statuses when in not_started state treat as dead
  '("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP"))

    "Kill Complete Run"
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt % "
             "  -state RUNNING,REMOTEHOSTSTART,LAUNCHING,LAUNCHED,NOT_STARTED"))))
   (iup:menu-item 
    "Delete Run Data"
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -remove-runs -target " target
             " -runname " runname

    #:action
    (lambda (obj)
      ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHING,LAUNCHED"))))
   (iup:menu-item
    (conc "Delete data : " item-test-path)
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -remove-runs -target " target
             " -runname " runname

    #:action
    (lambda (obj)
      ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHING,LAUNCHED,NOT_STARTED"))))
   
   (let* ((rundir    (db:test-get-rundir      test-info))
          (has-subrun (subrun:subrun-test-initialized? rundir)))
     (if has-subrun
         (iup:menu-item
          "Launch subrun dashboard"
          #:action

        (lambda (test-id run-dir uname testname item-path)
          (if (and (equal? uname "n/a")
                   (equal? item-path "")) ;; this is a toplevel test
              ;; what to do with toplevel? call rollup?
              (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
              (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
        db
        "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED','LAUNCHING');"
        run-id)
       
       (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
       (if (and (null? incompleted)
                (null? oldlaunched)
                (null? toplevels))
           #f

		       "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests 
                           WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?)
                                          AND state IN ('REMOTEHOSTSTART');"))
	      (stmth3 (db:get-cache-stmth
		       dbstruct db
		       "SELECT id,rundir,uname,testname,item_path FROM tests
                           WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400
                                          AND state IN ('LAUNCHED','LAUNCHING');")))
	 ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
	 ;;
	 ;; HOWEVER: this code in run:test seems to work fine
	 ;;              (> (- (current-seconds)(+ (db:test-get-event_time testdat)
	 ;;                     (db:test-get-run_duration testdat)))
	 ;;                    600) 
	 ;; (db:delay-if-busy dbdat)

	  -1 "-" "-"))

;;
;; 1. cache tests-match-qry
;; 2. compile qry and store in hash
;; 3. convert for-each-row to fold
;;
#;(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
  (db:with-db
   dbstruct run-id #f
   (lambda (db)
     (let* ((res            '())
	    (stmt-cache      (dbr:dbstruct-stmt-cache dbstruct))
	    (stmth           (let* ((sh (db:hoh-get stmt-cache db testpatt)))
			       (or sh

				       test-id))))))
  (mt:process-triggers dbstruct run-id test-id newstate newstatus))

;; NEW BEHAVIOR: Count tests running in all runs!
;;
(define (db:get-count-tests-running dbstruct run-id fastmode)
  (let* ((qry (if fastmode
		  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','LAUNCHING','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '') LIMIT 1;"
		  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','LAUNCHING','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');")))
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let* ((stmth (db:get-cache-stmth dbstruct  db qry)))
       (sqlite3:first-result stmth))))))

;; NEW BEHAVIOR: Count tests running in only one run!
;;
(define (db:get-count-tests-actually-running dbstruct run-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result
      db
      ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
      ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")
      "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART','LAUNCHED','LAUNCHING') AND run_id=?;" 
      run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")

;; NEW BEHAVIOR: Look only at single run with run-id
;; 
;; (define (db:get-running-stats dbstruct run-id)
(define (db:get-count-tests-running-for-run-id dbstruct run-id fastmode)
  (let* ((qry (if fastmode
		  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','LAUNCHING','REMOTEHOSTSTART') AND run_id=? LIMIT 1;"
		  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','LAUNCHING','REMOTEHOSTSTART') AND run_id=?;")))
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)
       (let* ((stmth (db:get-cache-stmth dbstruct db qry)))
	 (sqlite3:first-result stmth run-id))))))

;; For a given testname how many items are running? Used to determine
;; probability for regenerating html
;;
(define (db:get-count-tests-running-for-testname dbstruct run-id testname)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let* ((stmt "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;")
	    (stmth (db:get-cache-stmth dbstruct db stmt)))
       (sqlite3:first-result
	stmth run-id testname)))))

(define (db:get-not-completed-cnt dbstruct run-id)
(db:with-db
   dbstruct

	    (db:with-db
	     dbstruct
	     run-id
	     #f
	     (lambda (db)
	       (sqlite3:first-result
		db
		(conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('"
		      (string-intersperse testnames "','")
		      "') AND NOT (uname = 'n/a' AND item_path='');")) ;; should this include the (uname = 'n/a' ...) ???
	       ))
	    0))))

;; tags: '("tag%" "tag2" "%ag6")
;;

;; done with run when:
;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining dbstruct run-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result
      db
      "SELECT count(id) FROM tests WHERE state in ('LAUNCHING','LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ') AND run_id=?;")
     run-id)))

;; map run-id, testname item-path to test-id
(define (db:get-test-id dbstruct run-id testname item-path)
  (db:with-db
   dbstruct
   run-id

	 (begin
	   (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
           (print-call-chain (current-error-port))
	   msg))) ;; crude reply for when things go awry
    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg))) ;; rpc
















;; 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))
	 (item-path    (db:test-get-item-path testdat))
         (tl-testdat   (db:get-test-info dbstruct run-id test-name ""))
         (tl-test-id   (if tl-testdat
			   (db:test-get-id tl-testdat)
			   #f)))
    (if (member state '("LAUNCHING","LAUNCHED" "REMOTEHOSTSTART")) 
	(db:general-call dbstruct 'set-test-start-time (list test-id)))
    (mutex-lock! *db-transaction-mutex*)
    (db:with-db
     dbstruct #f #f
     (lambda (db)
       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                 ;; NB// Pass the db so it is part fo the transaction
                 (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status
                 (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
                     (let* ((state-status-counts  (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
			    (state-statuses       (db:roll-up-rules state-status-counts state status))
			    (newstate             (car state-statuses))
			    (newstatus            (cadr state-statuses)))
                       (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts)  " state-status-counts: "
							(apply conc
                  (map (lambda (x)
                     (conc
                     		(with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
                              state-status-counts))); end debug:print
   
                       (if tl-test-id
			   (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
		       ))))))
         (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)))))

(define (db:roll-up-rules state-status-counts state status)
  (let* ((running     (length (filter (lambda (x)
					(member (dbr:counts-state x) *common:running-states*))
				      state-status-counts)))
	 (bad-not-started      (length (filter (lambda (x)
						 (and (equal? (dbr:counts-state x) "NOT_STARTED") 
						      (not (member (dbr:counts-status x)  *common:not-started-ok-statuses*))))
					       state-status-counts)))
	 (all-curr-states      (common:special-sort  ;; worst -> best (sort of)
				(delete-duplicates
				 (if (and state (not (member state *common:dont-roll-up-states*)))
				     (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 (and state status (not (member state *common:dont-roll-up-states*)))
				     (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 (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
				       all-curr-states))
	 (preq-fails        (filter (lambda (x)
				      (equal? x "PREQ_FAIL"))
				    all-curr-statuses))
	 (num-non-completes (length non-completes))
	 (newstate          (cond
			     ((> running 0)             "RUNNING")          ;; anything running, call the situation running
			     ((and (> (length preq-fails) 0)
				   (> num-non-completes 0)) "NOT_STARTED")  ;; not really sure about this one - mrw - Sep 7, 2020 - trying to fix NOT_STARTED/PREREQ_FAILS in itemized rollup
			     ((> bad-not-started 0)     "COMPLETED")        ;; we have an ugly situation, it is completed in the sense we cannot do more.
			     ((> 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))))
	 (newstatus         (cond
			     ((> (length preq-fails) 0)  "PREQ_FAIL")
			     ((or (> bad-not-started 0)
				  (and (equal? newstate "NOT_STARTED")
				       (> num-non-completes 0)))
			      "STARTED")
			     (else (car all-curr-statuses)))))
    (debug:print-info 2 *default-log-port*
		      "\n--> probe db:set-state-status-and-roll-up-items: "
		      "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
		      "\n--> running:             "running
		      "\n--> bad-not-started:     "bad-not-started
		      "\n--> non-non-completes:   "num-non-completes
		      "\n--> non-completes:       "non-completes
		      "\n--> all-curr-states:     "all-curr-states
		      "\n--> all-curr-statuses:     "all-curr-statuses
		      "\n--> newstate              "newstate
		      "\n--> newstatus            "newstatus
		      "\n\n")
    
    ;; NB// Pass the db so it is part of the transaction
    (list newstate newstatus)))

(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
    (mutex-lock! *db-transaction-mutex*)
    (db:with-db
     dbstruct #f #f
     (lambda (db)
       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                   (let* ((state-status-counts  (db:get-all-state-status-counts-for-run dbstruct run-id))
			  (state-statuses       (db:roll-up-rules state-status-counts #f #f ))
                          (newstate             (car state-statuses))
                          (newstatus            (cadr state-statuses))) 
                    (if (or (not (eq? newstate curr-state)) (not (eq?  newstatus curr-status)))
                   (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
         (mutex-unlock! *db-transaction-mutex*)
         tr-res))))


(define (db:get-all-state-status-counts-for-run dbstruct run-id)

                                                     AND item_path != '' 
                                                     AND status NOT IN ('n/a')
                                                     AND state in ('NOT_STARTED')) > 0 THEN 'UNKNOWN'
                                   WHEN (SELECT count(id) FROM tests 
                                                WHERE testname=?
                                                     AND item_path != '' 
                                                     AND (status NOT IN ('TEN_STRIKES','BLOCKED') OR status IN ('INCOMPLETE'))
                                                     AND state in ('RUNNING','NOT_STARTED','LAUNCHING','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
                                   WHEN (SELECT count(id) FROM tests 
                                                WHERE testname=?
                                                     AND item_path != '' 
                                                     AND state NOT IN ('COMPLETED','DELETED')) = 0 THEN 'COMPLETED'
                                   WHEN (SELECT count(id) FROM tests 
                                                WHERE testname=?
                                                     AND item_path != '' 

                              (debug:print 0 *default-log-port*
                               "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
			      res))))
	    (if (null? tal)
		newr
		(loop (car tal)(cdr tal) newr)))))))




;; 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: 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

  (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))
						  '("LAUNCHING" "LAUNCHED" "REMOTEHOSTSTART" "RUNNING") ;; states
						  '()          ;; statuses
						  #f           ;; offset
						  #f           ;; limit
						  #f           ;; not-in
						  #f           ;; sort by
						  #f           ;; sort order
						  'shortlist   ;; query type

				    (dboard:tabdat-test-patts-use tabdat))
			   #:expand "YES"
			   #:size "x30" ;; was 10x30
			   #:multiline "YES")))
      (set! test-patterns-textbox tb)
      (dboard:tabdat-test-patterns-textbox-set! tabdat tb)
      tb))


























   ))

(define (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)
  (iup:frame
   #:title "Tests and Tasks"
   (let* ((updater #f)
	  (last-xadj 0)

<!DOCTYPE html>
<html lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<meta name="generator" content="AsciiDoc 8.6.10">
<title>The Megatest Users Manual</title>
<style type="text/css">
/* Shared CSS for AsciiDoc xhtml11 and html5 backends */

/* Default font. */
body {
  font-family: Georgia,serif;

ul, ol, li > p {
  margin-top: 0;
}
ul > li     { color: #aaa; }
ul > li > * { color: black; }

.monospaced, code, pre {
  font-family: "Courier New", Courier, monospace;
  font-size: inherit;
  color: navy;
  padding: 0;
  margin: 0;
}
pre {
  white-space: pre-wrap;
}

#author {
  color: #527bbd;
  font-weight: bold;
  font-size: 1.1em;
}
#email {

div.exampleblock > div.content {
  border-left: 3px solid #dddddd;
  padding-left: 0.5em;
}

div.imageblock div.content { padding-left: 0; }
span.image img { border-style: none; vertical-align: text-bottom; }
a.image:visited { color: white; }

dl {
  margin-top: 0.8em;
  margin-bottom: 0.8em;
}
dt {

/*
 * xhtml11 specific
 *
 * */







div.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
div.tableblock > table {
  border: 3px solid #527bbd;
}

/*
 * html5 specific
 *
 * */







table.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
thead, p.tableblock.header {
  font-weight: bold;
  color: #527bbd;

body.manpage div.sectionbody {
  margin-left: 3em;
}

@media print {
  body.manpage div#toc { display: none; }
}


@media screen {
  body {
    max-width: 50em; /* approximately 80 characters wide */
    margin-left: 16em;
  }

  #toc {

<div class="imageblock">
<div class="content">
<img src="megatest-system-architecture.png" alt="Static">
</div>
</div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_road_map">Road Map</h2>
<div class="sectionbody">
</div>
</div>
<div class="sect1">
<h2 id="_todo_road_map">TODO / Road Map</h2>
<div class="sectionbody">
<div class="paragraph"><p>Note: This road-map is a wish list and not a formal plan. Items are in
rough priority but are subject to change. Development is driven by
user requests, developer "itch" and bug reports. Please contact

</div>
<div class="sect1">
<h2 id="_installation">Installation</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_dependencies">Dependencies</h3>
<div class="paragraph"><p>Chicken scheme and a number of "eggs" are required for building
Megatest. See the script installall.sh in the utils directory of the
source distribution for an automated way to install everything
needed for building Megatest on Linux.</p></div>
<div class="paragraph"><p>Megatest. In the v1.66 and beyond assistance to create the build
system is built into the Makefile.</p></div>
<div class="listingblock">
<div class="title">Installation steps (overview)</div>
<div class="content monospaced">
<pre>./configure
make chicken
setup.sh make -j install</pre>

</div></div>
</div>
<div class="sect2">
<h3 id="_trim_trailing_spaces">Trim trailing spaces</h3>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/usr/images/icons/note.png" alt="Note">
</td>
<td class="content">As of Megatest version v1.6548 trim-trailing-spaces defaults to yes.</td>
</tr></table>
</div>
<div class="listingblock">
<div class="content monospaced">
<pre>[configf:settings trim-trailing-spaces no]

<pre># A normal waiton waits for the prior tests to be COMPLETED
# and PASS, CHECK or WAIVED
waiton test1 test2</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/usr/images/icons/note.png" alt="Note">
</td>
<td class="content">Dynamic waiton lists must be capable of being calculated at the
beginning of a run. This is because Megatest walks the tree of waitons
to create the list of tests to execute.</td>
</tr></table>
</div>
<div class="listingblock">

item is COMPLETED and PASS, CHECK or WAIVED in the prior test. This
was historically called "itemwait" mode. The terms "itemwait" and
"itemmatch" are synonyms.</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>[requirements]
mode itemmatch</pre>
</div></div>
<div class="paragraph"><p>Exclusive mode allows only one instance of a particular test to run at a time.</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>[requirements]
mode exclusive</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/usr/images/icons/note.png" alt="Note">
</td>
<td class="content">Modes can be combined</td>
</tr></table>
</div>
<div class="listingblock">
<div class="content monospaced">
<pre>[requirements]
mode toplevel exclusive</pre>
</div></div>
</div>
<div class="sect2">
<h3 id="_overriding_enviroment_variables">Overriding Enviroment Variables</h3>
<div class="paragraph"><p>Override variables before starting the test. Can include files (perhaps generated by megatest -envdelta or similar).</p></div>
<div class="listingblock">
<div class="content monospaced">

<div class="content monospaced">
<pre>[triggers]
COMPLETED/ xterm -e bash -s --</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/usr/images/icons/note.png" alt="Note">
</td>
<td class="content">There is a trailing space after the double-dash</td>
</tr></table>
</div>
<div class="paragraph"><p>There are a number of environment variables available to the trigger script
but since triggers can be called in various contexts not all variables are
available at all times. The trigger script should check for the variable and

</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.5<br>
Last updated
 2020-08-22 12:47:36 MST
</div>
</div>
</body>
</html>

was historically called "itemwait" mode. The terms "itemwait" and
"itemmatch" are synonyms.

-------------------
[requirements]
mode itemmatch
-------------------

Exclusive mode allows only one instance of a particular test to run at a time.

-------------------
[requirements]
mode exclusive
-------------------

NOTE: Modes can be combined

-------------------
[requirements]
mode toplevel exclusive
-------------------

Overriding Enviroment Variables
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Override variables before starting the test. Can include files (perhaps generated by megatest -envdelta or similar).

--------------------

       (else (list "180 33 49" status))))
    ;;      (if (equal? status "PASS")
    ;;	  '("70 249 73" "PASS")
    ;;	  (if (or (equal? status "WARN")
    ;;		  (equal? status "WAIVED"))
    ;;	      (list "255 172 13" status)
    ;;	      (list "223 33 49"  status)))) ;; greenish orangeish redish
    ((LAUNCHED LAUNCHING) (list "101 123 142"  state))
    ((CHECK)              (list "255 100 50"   state))
    ((REMOTEHOSTSTART)    (list "50 130 195"   state))
    ((RUNNING STARTED)    (list "9 131 232"    state))
    ((KILLREQ)            (list "39 82 206"    state))
    ((KILLED)             (list "234 101 17"   state))
    ((NOT_STARTED)        (case (string->symbol status)
			    ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state))
			    (else   (list "240 240 240"                 state))))
    ;; for xor mode below
    ;;
    ((CLEAN)
     (case (string->symbol status)
       ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT)  (list "200 130 13" status)) ;; orange requested for these
       (else  (list "60  235 63" status))))
    ((DIRTY-BETTER)     (list "160  255 153" status))

        	  (debug:print 0 *default-log-port* "There are " running-cnt " tests running." ))
        ((> running-cnt 0)
            (debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" )
   				  (let ((kill-cnt (launch:kill-tests-if-dead run-id)))
           			(if (and all-test-launched  (equal? all-test-launched "yes") (eq? kill-cnt running-cnt))
           					(launch:end-of-run-check run-id)))) ;;todo
        (else  (debug:print 0 *default-log-port* "Should it get here?? May be everything is not launched yet. Running test cnt:" running-cnt " Not completed test cnt:" not-completed-cnt)
         (let* ((not-completed-tests (rmt:get-tests-for-run run-id "%" `("NOT_STARTED" "RUNNING" "LAUNCHING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
       (if (> (length not-completed-tests) 0) 
           (let loop ((running-test (car not-completed-tests))
			     (tal    (cdr not-completed-tests)))
		       (let* ((test-name (vector-ref running-test 2))
                 (item-path (vector-ref running-test 11)))
			       	(debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed")
              (if (not (null? tal))
				  (loop (car tal) (cdr tal)))))))))))        
 
(define (launch:is-test-alive host pid)
  (if (and host pid (not (equal? host "n/a")))
      (let* ((cmd (conc "ssh " host " pstree -A " pid))
	     (output (with-input-from-pipe cmd read-lines)))
	(debug:print 2 *default-log-port* "Running " cmd " received " output)
	(if (eq? (length output) 0)
	   #f
	   #t))
      #t))
 
(define (launch:kill-tests-if-dead run-id)
  (let* ((running-tests (rmt:get-tests-for-run run-id "%" `("RUNNING" "LAUNCHING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
       (let loop ((running-test (car running-tests))
			     (tal    (cdr running-tests))
			     (kill-cnt 0))
		       (let* ((test-name (vector-ref running-test 2))
                 (item-path (vector-ref running-test 11))
								 (test-id (vector-ref running-test 0))
                 (host (vector-ref running-test 6))

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

;; (declare (unit megatest-version))

(define megatest-version 1.6568)

  (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))