Megatest

	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/nbfind : utils/nbfind
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/mtrunner : utils/mtrunner
	$(INSTALL) $< $@
	chmod a+x $@

# $(PREFIX)/bin/refdb : refdb
# 	$(INSTALL) $< $@
# 	chmod a+x $@

	utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
	chmod a+x $(PREFIX)/bin/dashboard
	$(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard

install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
          $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
          $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
	  $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \
          $(PREFIX)/share/js/jquery-3.1.0.slim.min.js 
#         $(PREFIX)/bin/.$(ARCHSTR)/ndboard

# $(PREFIX)/bin/newdashboard

INFO: (0) Number non-cached queries 74289
INFO: (0) Average non-cached time   1055.09826488444 ms
INFO: (0) Server shutdown complete. Exiting

Start: 0 at Sun Apr 28 22:18:25 MST 2013
Max:  52 at Sun Apr 28 23:06:59 MST 2013
End:   6 at Sun Apr 28 23:47:51 MST 2013

========================================================================

	(hash-table-ref blockid-cache key)
	(let* ((pscript     (configf:lookup *configdat* "archive" "pathscript"))
	       (pscript-cmd (conc pscript " " testsuite-name " " target " " run-name " " test-name))
	       (apath       (if pscript
				(handle-exceptions
				 exn
				 (begin
				   (debug:print 0 *default-log-port* "ERROR: script \"" pscript-cmd "\" failed to run properly.")
				   (exit 1))
				 (with-input-from-pipe
				  pscript-cmd
				  read-line))
				#f)) ;; this is the user-calculated archive path
	       (adisks    (archive:get-archive-disks))
	       (best-disk (common:get-disk-with-most-free-space adisks dneeded)))

		     (archive-path  (conc bdisk-path "/" archive-name))
		     (block-id      (rmt:archive-register-block-name bdisk-id archive-path)))
		;;   (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key)))
		(if block-id ;; (and block-id allocation-id)
		    (let ((res (cons block-id archive-path)))
		      (hash-table-set! blockid-cache key res)
		      res)
		    (begin
		      (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ",  archive-path=" archive-path)
		      #f)))
	      (begin
		(debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ", block-id=" block-id)
		#f)))))) ;; no best disk found


;; archive - run bup
;;
;; 1. create the bup dir if not exists
;; 2. start the du of each directory
;; 3. gen index
;; 4. save

				     (substring test-physical-path
						0
						partial-path-index)
				     #f))
	      ;; we need our archive dir checked for every test to enable folks who want to store other ways.
	      (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target run-name test-name))
	      (archive-dir  (if archive-info (cdr archive-info) #f))
	      (archive-id   (if archive-info (car archive-info) -1)))


	 
	 (if (not archive-dir) ;; no archive disk found, this is fatal
	     (begin
	       (debug:print 0 *default-log-port* "FATAL: No archive disks found. Please add disks with at least "
			    min-space " MB space to the [archive-disks] section of megatest.config")
	       (debug:print 0 *default-log-port* "       use [archive] minspace to specify minimum available space")
	       (debug:print 0 *default-log-port* "   disks: "

     (lambda (test-base)
       (let* ((disk-group (hash-table-ref disk-groups test-base))
	      (arch-group (hash-table-ref arch-groups test-base))
	      (arch-info  (car arch-group)) ;; don't know yet how this will work, can I get more than one possibility?
	      (archive-id    (car arch-info))
	      (archive-dir   (cdr arch-info)))
	 (debug:print 0 *default-log-port* "Processing disk-group " test-base)
	 (let* ((test-paths-in (hash-table-ref disk-groups test-base))
		(test-paths    (if (args:get-arg "-include")
				   (let ((subpaths (string-split (args:get-arg "-include") ",")))
				     (apply append
					    (map (lambda (p)
						   (map (lambda (subp)
							  (conc p "/" subp))
							subpaths))
						 test-paths-in)))
				   test-paths-in)))
	   (if (not (common:file-exists? archive-dir))
	       (create-directory archive-dir #t))
	   (case archiver
	     ((bup) ;; Archive using bup
	      (let* ((bup-init-params  (list "-d" archive-dir "init"))
		     (bup-index-params (append (list "-d" archive-dir "index") test-paths))
		     (bup-save-params  (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)

	       (hash-table-ref test-groups test-base))))
	   ;; (mutex-unlock! bup-mutex)
	   (for-each
	    (lambda (test-dat)
	      (let ((test-id           (db:test-get-id        test-dat))
		    (run-id            (db:test-get-run_id    test-dat)))
		(rmt:test-set-archive-block-id run-id test-id archive-id)
		(if (member (symbol->string archive-command) '("save-remove"))
                    (begin 
                     (debug:print-info 0 *default-log-port* "remove testdat")
		    (runs:remove-test-directory test-dat 'archive-remove)))))
	    (hash-table-ref test-groups test-base)))))
       (hash-table-keys disk-groups))
    #t))

(define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex)  ;; move the getting of archive space down into the below block so that a single run can 
  ;; allocate as needed should a disk fill up
  ;;

	      (mutex-unlock! rp-mutex)
	      (new-test-physical-path  (conc best-disk "/" test-partial-path))
	      (archive-block-id        (db:test-get-archived test-dat))
	      (archive-block-info      (rmt:test-get-archive-block-info archive-block-id))
	      (archive-path            (if (vector? archive-block-info)
					   (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
					   #f)) ;; no archive found?
	      (archive-internal-path   (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path))
	      (include-paths           (args:get-arg "-include"))
	      (exclude-pattern         (args:get-arg "-exclude-rx"))
	      (exclude-file            (args:get-arg "-exclude-rx-from")))
	 
	 ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children
	 ;;
	 (if (and (not toplevel/children)  ;; special handling needed for toplevel with children
		  prev-test-physical-path
		  (common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
	     (let* ((base (pathname-directory prev-test-physical-path))

		 (debug:print-info 0 *default-log-port* "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path)
		 ;; (mutex-lock! bup-mutex)
		 (run-n-wait bup-exe params: bup-restore-params print-cmd: #f)
		 ;; (mutex-unlock! bup-mutex)
		 (mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f)))
	     (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))
     (filter vector? tests))))

(define (common:get-youngest-test tests)
  (if (null? tests)
      #f
      (let ((res #f))
	(for-each
	 (lambda (test-dat)
	   (let ((event-time (db:test-get-event_time test-dat)))
	     (if (or (not res)
		     (> event-time (db:test-get-event_time res)))
		 (set! res test-dat))))
	 tests)
	res)))
	   
;; from an archive get a specific path - works ONLY with bup for now
;;
(define (archive:bup-get-data archive-command run-id-in run-name-in tests rp-mutex bup-mutex)
  (if (null? tests)
      (debug:print-info 0 *default-log-port* "get-data called with no matching tests to operate on.")
      
      (let* ((bup-exe      (or (configf:lookup *configdat* "archive" "bup") "bup"))
	     (linktree     (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
	     ;; (test-dat     (common:get-youngest-test tests))
	     (destpath     (args:get-arg "-dest")))
	(cond
	 ((null? tests)
	  (debug:print-error 0 *default-log-port*
			     "No test matching provided target, runname pattern and test pattern found."))
	 ((file-exists? destpath)
	  (debug:print-error 0 *default-log-port*
			     "Destination path alread exists! Please remove it before running get."))
	 (else
	  (let loop ((rem-tests tests))
	    (let* ((test-dat          (common:get-youngest-test rem-tests))
		   (item-path         (db:test-get-item-path test-dat))
		   (test-name         (db:test-get-testname  test-dat))
		   (test-id           (db:test-get-id        test-dat))
		   (run-id            (db:test-get-run_id    test-dat))
		   (run-name          (rmt:get-run-name-from-id run-id))
		   (keyvals           (rmt:get-key-val-pairs run-id))
		   (target            (string-intersperse (map cadr keyvals) "/"))
		   
		   (toplevel/children (and (db:test-get-is-toplevel test-dat)
					   (> (rmt:test-toplevel-num-items run-id test-name) 0)))
		   (test-partial-path (conc target "/" run-name "/"
					    (db:test-make-full-name test-name item-path)))
		   ;; note the trailing slash to get the dir inspite of it being a link
		   (test-path         (conc linktree "/" test-partial-path))
		   (archive-block-id        (db:test-get-archived test-dat))
		   (archive-block-info      (rmt:test-get-archive-block-info archive-block-id))
		   (archive-path            (if (vector? archive-block-info)
						(vector-ref archive-block-info 2)
						#f))
		   (archive-internal-path   (conc (common:get-testsuite-name) "-" run-id
						  "/latest/" test-partial-path))
		   (include-paths           (args:get-arg "-include"))
		   (exclude-pattern         (args:get-arg "-exclude-rx"))
		   (exclude-file            (args:get-arg "-exclude-rx-from")))
	      
	      (if (and archive-path ;; no point in proceeding if there is no actual archive
		       (not toplevel/children))
		  (begin
		    (let* ((bup-restore-params (append (list "-d" archive-path "restore" "-C" (or destpath "data"))
						       ;; " " ;; What is the empty string for?
						       (if include-paths
							   (map (lambda (p)
								  (conc archive-internal-path "/" p))
								(string-split include-paths ","))
							   (list archive-internal-path)))))
		      (debug:print-info 0 *default-log-port* "Restoring archived data to " (or destpath "data")
					" from archive in " archive-path " ... " archive-internal-path)
		      (run-n-wait bup-exe params: bup-restore-params print-cmd: #t)))
		  (let ((new-rem-tests (filter (lambda (tdat)
						 (or (not (eq? (db:test-get-id tdat) test-id))
						     (not (eq? (db:test-get-run_id tdat) run-id))))
					       rem-tests) ))
		    (debug:print-info 0 *default-log-port*
				      "No archive path in the record for run-id=" run-id
				      " test-id=" test-id ", skipping.")
		    (if (null? new-rem-tests)
			(begin
			  (debug:print-info 0 *default-log-port* "No archives found for " target "/" run-name "...")
			  #f)
			(loop new-rem-tests)))))))))))
  

;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(use json)
(use ducttape-lib)

(define (get-last-runname area-path target)
  (let* ((run-data     (with-input-from-pipe (conc "megatest -list-runs % -target " target " -fields runs:runname,event_time -dumpmode sexpr -start-dir " area-path)
			 read)))
    (if (or (not run-data)
	    (null? run-data))
	#f
	(let* ((name-time    (let ((dat (map cdadr (alist-ref target run-data equal?)))) ;; (("runname" . "2017w07.0-0047") ("event_time" . "1487490424"))
			       ;; (print "dat=" dat)
			       (map (lambda (item)
				      (cons (alist-ref "runname" item equal?)
					    (string->number (alist-ref "event_time" item equal?))))
				    dat)))
	       (sorted       (sort name-time (lambda (a b)(> (cdr a)(cdr b)))))
	       (last-name    (if (null? sorted)
				 #f
				 (caar sorted))))
	  last-name))))

(define (str-first-char->number str)
  (char->integer (string-ref str 0)))
 
;; example of how to set up and write target mappers
;; NOTE: maps a *list* of targets!
;;
;; (? target run-name area area-path reason contour mode-patt)
;;
(add-target-mapper 'prefix-contour 
		   (lambda (runkey area contour)
		     (print "target: " runkey)
		     (list (conc contour "/" runkey))))
#;(add-target-mapper 'prefix-area-contour
		   (lambda (target run-name area area-path reason contour mode-patt)
		     (conc area "/" contour "/" target)))
  
(add-runname-mapper 'corporate-ww
		    (lambda (target run-name area area-path reason contour mode-patt)
		      (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt)
		      (let* ((last-name   (get-last-runname area-path target))
			     (last-letter (let* ((ch (if (string? last-name)
							 (let ((len (string-length last-name)))
							   (substring last-name (- len 1) len))
							 "a"))
						 (chnum (str-first-char->number ch))
						 (a     (str-first-char->number "a"))
						 (z     (str-first-char->number "z")))
					    (if (and (>= chnum a)(<= chnum z))
						chnum
						#f)))
			     (next-letter (if last-letter
					      (list->string
					       (list
						(integer->char
						 (+ last-letter 1)))) ;; surely there is an easier way?
					      "a")))
			;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter)
			(conc (seconds->wwdate (current-seconds)) next-letter))))

(add-runname-mapper 'auto
		    (lambda (target run-name area area-path reason contour mode-patt)
		      "auto-eh"))

;; run only areas where first letter of area name is "a"
;;
(add-area-checker 'first-letter-a
                  (lambda (area target contour)
                    (string-match "^a.*$" area)))

#  Copyright 2006-2017, Matthew Welland.
# 
# This file is part of Megatest.
# 
#     Megatest is free software: you can redistribute it and/or modify
#     it under the terms of the GNU General Public License as published by
#     the Free Software Foundation, either version 3 of the License, or
#     (at your option) any later version.
# 
#     Megatest is distributed in the hope that it will be useful,
#     but WITHOUT ANY WARRANTY; without even the implied warranty of
#     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#     GNU General Public License for more details.
# 
#     You should have received a copy of the GNU General Public License
#     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

## commented out due to a bug in v1.6501 in mtutil
[fields]
a text
b text
c text

[default]
# usercode    .mtutil.scm
# areafilter  area-to-run
# targtrans   generic-target-translator
# runtrans    generic-runname-translator
usercode    .mtutil.scm
# areafilter  area-to-run
targtrans   prefix-contour-broken
# runtrans    generic-runname-translator

[setup]
pktsdirs /mfs/home/matt/orion_automation/pkts

[areas]

#         path-to-area   map-target-script(future, optional)
# someqa     path=../megatestqa/someqa; targtrans=somefunc; areafilter=area-to-run
# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run
#           the target translator can return: a/target OR (list/of targets/to apply/run)
#           OR #f i.e. run nothing

# ext-tests path=ext-tests; targtrans=prefix-contour;


ext       path=/mfs/home/matt/automation_areas/megatest/ext-tests; targtrans=prefix-contour

[contours]
#     selector=tag-expr/mode-patt
quick areas=ext;    selector=/QUICKPATT
# quick2 areafn=check-area; selector=/QUICKPATT
full  areas=ext
# quick areas=fullrun,ext-tests; selector=QUICKPATT/quick
# full  areas=fullrun,ext-tests; selector=MAXPATT/
# short areas=fullrun,ext-tests; selector=MAXPATT/
# all   areas=fullrun,ext-tests
# snazy selector=QUICKPATT/

[nopurpose]

[access]
ext matt:admin mattw:owner

[accesstypes]
admin run rerun resume remove set-ss rerun-clean
owner run rerun resume remove rerun-all
badguy set-ss

[setup]
maxload 1.2

[listeners]
localhost:12345  contact=matt@kiatoa.com
localhost:54321  contact=matt@kiatoa.com

[listener]
script nbfake echo


[server]
timeout 1

[include local.config]

#  Copyright 2006-2017, Matthew Welland.
# 
# This file is part of Megatest.
# 
#     Megatest is free software: you can redistribute it and/or modify
#     it under the terms of the GNU General Public License as published by
#     the Free Software Foundation, either version 3 of the License, or
#     (at your option) any later version.
# 
#     Megatest is distributed in the hope that it will be useful,
#     but WITHOUT ANY WARRANTY; without even the implied warranty of
#     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#     GNU General Public License for more details.
# 
#     You should have received a copy of the GNU General Public License
#     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

# To get emacs font highlighing in the various megatest configs do this:
#
# Install emacs-goodies-el:
#    sudo apt install emacs-goodies-el
# Add to your ~/.emacs file:
#    (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode))
#

# example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config
#
[a/b/c]
# all:scheduled:sync     cron=  0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config
# quick:scheduled:sync   cron=  0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config
# fast:scheduled:sync-prepend cron=  0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config

# [scriptinc ./gentargets.sh #{getenv USER}]
# [v1.23/45/67]

# tip will be replaced with hashkey?

# [%/%/%] doesn't work

[/.*/]

[v1.65/tip/dev]
# file:   files changes since last run trigger new run
# script: script is called with unix seconds as last parameter (other parameters are preserved)
#
# contour:sensetype:action params            data
# commented out for debug

quick:file:run             runtrans=auto;         glob=/nfs/orion/disk1/mfs_home/home/matt/automation_areas/megatest/*.scm foo.touchme
# snazy:file:run             runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm
# short:file:run       runtrans=short;        glob=/home/matt/data/megatest/*.scm

# script returns change-time (unix epoch), new-target-name, run-name
#
# quick:script:run           checkfossil = http://www.kiatoa.com/fossils/megatest v1.63;\
#                            checkfossil = http://www.kiatoa.com/fossils/megatest_qa trunk

# # fossil based trigger
# #
quick:fossil:run           http://www.kiatoa.com/fossils/megatest=v1.65;\
                           http://www.kiatoa.com/fossils/megatest_qa=trunk

# field          allowed values
# -----          --------------
# minute         0-59
# hour           0-23
# day of month   1-31
# month          1-12 (or names, future development)
# day of week    0-7 (0 or 7 is Sun, or, future development, use names)

# actions:
#  run     - run a testsuite
#  clean   - clear out runs
#  archive - archive runs

# quick:scheduled:run     cron=47  * * * * ;run-name=auto
# quick:scheduled:archive cron=15 20 * * * ;run-name=%;target=%/%/%

# [%]
# # every friday at midnight clean "all" tests over 7d
# all:scheduled:clean     cron=  0  0 0 0 5;run-name=%;age=7d   

[v1.65/tip/dev]
# # file:   files changes since last run trigger new run
# # script: script is called with unix seconds as last parameter (other parameters are preserved)
# #
# # contour:sensetype:action params            data
# quick:file:run             run-name=auto;glob=*.scm
# quick:file:clean           run-name=auto;
# quick:script:run           run-name=auto;script=checkfossil.sh v1.63
# 
# # field          allowed values
# # -----          --------------
# # minute         0-59
# # hour           0-23
# # day of month   1-31
# # month          1-12 (or names, future development)
# # day of week    0-7 (0 or 7 is Sun, or, future development, use names)
# 
# # actions:
# #  run     - run a testsuite
# #  clean   - clear out runs
# #  archive - archive runs
# 
quick:scheduled:run     cron=47  * * * * ;run-name=auto
# quick:scheduled:archive cron=15 20 * * * ;run-name=% ; 
#

[%/%/%]
# # every friday at midnight clean "all" tests over 7d
all:scheduled:clean     cron=  0  0 0 0 5;run-name=%;age=7d   
# 

source /opt/chicken/4.13.0_18.04_WW45/setup-chicken4x.sh 
export PATH=/mfs/home/matt/orion_automation/bin:$PATH

	(max-allowed (string->number (or (configf:lookup *configdat* "setup" "max-logfiles") "300")))) ;; name -> age
    (if (not (directory-exists? "logs"))(create-directory "logs"))
    (directory-fold 
     (lambda (file rem)
       (handle-exceptions
	exn
	(begin
	  (debug:print-info 2 *default-log-port* "unable to rotate log " file ", probably handled by another process, this is safe to ignore.")
	  (debug:print 2 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	  ;; (print-call-chain (current-error-port)) ;; 
	  )
	(let* ((fullname  (conc "logs/" file))
	       (mod-time  (file-modification-time fullname))
	       (file-age  (- (current-seconds) mod-time)))
	  (hash-table-set! all-files file mod-time)
	  (if (or (and (string-match "^.*.log" file)
		       (> (file-size fullname) 200000))
		  (and (string-match "^server-.*.log" file)

   (read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))

;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
  (let ((fmod-time (handle-exceptions
		       ext
		     (current-seconds)
		     (file-modification-time fname))))
    (if (common:file-exists? fname)
	(if (> (- (current-seconds) fmod-time) expire-time)
	    (begin
	      (handle-exceptions exn #f (delete-file* fname))	
	      (common:simple-file-lock fname expire-time: expire-time))
	    #f)
	(let ((key-string (conc (get-host-name) "-" (current-process-id))))
	  (with-output-to-file fname
	    (lambda ()
	      (print key-string)))
	  (thread-sleep! 0.25)
	  (if (common:file-exists? fname)
	      (handle-exceptions exn
                #f 
                (with-input-from-file fname
	  	  (lambda ()
		    (equal? key-string (read-line)))))
	      #f)))))

(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
  (let ((end-time (+ expire-time (current-seconds))))
    (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
      (if got-lock
	  #t
	  (if (> end-time (current-seconds))

(define (common:get-testsuite-name)
  (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
      (configf:lookup *configdat* "setup" "testsuite" )
      (getenv "MT_TESTSUITE_NAME")
      (if (string? *toppath* )
          (pathname-file *toppath*)
          #f))) ;; (pathname-file (current-directory)))))

;; safe getting of toppath
(define (common:get-toppath areapath)
  (or *toppath*
      (if areapath
	  (begin
	    (set! *toppath* areapath)
	    (setenv "MT_RUN_AREA_HOME" areapath)
	    areapath)
	  #f)
      (if (getenv "MT_RUN_AREA_HOME")
	  (begin
	    (set! *toppath* (getenv "MT_RUN_AREA_HOME"))
	    *toppath*)
	  #f)
      ;; last resort, look for megatest.config
      (let loop ((thepath (realpath ".")))
	(if (file-exists? (conc thepath "/megatest.config"))
	    thepath
	    (if (equal? thepath "/")
		(begin
		  (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.")
		  #f)
		(loop (pathname-directory thepath)))))
      ))

(define common:get-area-name common:get-testsuite-name)

(define (common:get-db-tmp-area . junk)
  (if *db-cache-path*
      *db-cache-path*
      (if *toppath* ;; common:get-create-writeable-dir

;; use bash to expand a glob. Does NOT handle paths with spaces!
;;
(define (common:bash-glob instr)
  (string-split
   (with-input-from-pipe
       (conc "/bin/bash -c \"echo " instr "\"")
       read-line)))

;;======================================================================
;; Some safety net stuff
;;======================================================================

;; return input if it is a list or return null
(define (common:list-or-null inlst #!key (ovrd #f)(message #f))
  (if (list? inlst)
      inlst
      (begin
	(if message (debug:print-error 0 *default-log-port* message))
	(or ovrd '()))))
  
;;======================================================================
;; T A R G E T S  ,   S T A T E ,   S T A T U S ,   
;;                    R U N N A M E    A N D   T E S T P A T T
;;======================================================================

;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t))))

       path-string
       #f)))

(define (common:get-linktree)
  (or (getenv "MT_LINKTREE")
      (if *configdat*
	  (configf:lookup *configdat* "setup" "linktree")
	  #f)
      (if (or *toppath* (getenv "MT_RUN_AREA_HOME"))
	  (conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt")
	  #f)
      (let* ((tp (common:get-toppath #f))
	     (lt (conc tp "/lt")))
	(if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt))
	lt)))

(define (common:args-get-runname)
  (let ((res (or (args:get-arg "-runname")
		 (args:get-arg ":runname")
		 (getenv "MT_RUNNAME"))))
    ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
    res))

;; 			    (set! cpu-load newval))))))
;; 	      (car load-res))
;;     cpu-load))

;; get values from cached info from dropping file in logs dir
;;  e.g. key is host and dtype is normalized-load
;;
(define (common:get-cached-info key dtype #!key (age 10))
  (if *toppath*
      (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log")))
	(if (and (file-exists? fullpath)
		 (file-read-access? fullpath))
	    (handle-exceptions
	     exn
	     #f
	     (debug:print 2 *default-log-port* "reading file " fullpath)
	     (let ((real-age (- (current-seconds)(file-change-time fullpath)))) 
	       (if (< real-age age)
		   (handle-exceptions
		       exn
		     (begin
		       (debug:print-info 1 *default-log-port* " removing bad file " fullpath)
		       (delete-file* fullpath)
		       #f)
		     (with-input-from-file fullpath read))
		   (begin
		     (debug:print-info 2 *default-log-port* "file " fullpath " is too old (" real-age" seconds) to trust, skipping reading it")
		     #f))))
	    (begin
	      (debug:print 2 *default-log-port* "not reading file " fullpath)
	      #f)))
      #f))
 
(define (common:write-cached-info key dtype dat)
  (if *toppath*
      (let* ((fulldir  (conc *toppath* "/.sysdata"))
	     (fullpath (conc fulldir "/" key "-" dtype ".log")))
	(if (not (file-exists? fulldir))(create-directory fulldir #t))
	(handle-exceptions
	 exn
	 #f
	 (with-output-to-file fullpath (lambda ()(pp dat)))))
      #f))
  
;; get cpu load by reading from /proc/loadavg, return all three values
;;
(define (common:get-cpu-load remote-host)
  (handle-exceptions
   exn
   '(99 99 99)
   (let* ((actual-hostname (or remote-host (get-host-name) "localhost")))

(define (common:get-num-cpus remote-host)
  (let* ((actual-host (or remote-host (get-host-name))))
    (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (random 3600))) ;; hosts had better not be changing the number of cpus too often!
	(let* ((proc   (lambda ()
			 (let loop ((numcpu 0)
				    (inl    (read-line)))
			   (if (eof-object? inl)

			       (if (> numcpu 0)
				   numcpu
				   #f) ;; if zero return #f so caller knows that things are not working
			       (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl)
					 (+ numcpu 1)
					 numcpu)
				     (read-line))))))
	       (result (if remote-host
			   (with-input-from-pipe 
			       (conc "ssh " remote-host " cat /proc/cpuinfo")
			     proc)
			   (with-input-from-file "/proc/cpuinfo" proc))))
	  (if (and (number? result)
		   (> result 0))
	      (common:write-cached-info actual-host "num-cpus" result))
	  result))))

;; wait for normalized cpu load to drop below maxload
;;
(define (common:wait-for-normalized-load maxload msg remote-host #!optional (rem-tries 5))
  (let ((num-cpus (common:get-num-cpus remote-host)))
    (if num-cpus
	(common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host)
	(begin
	  (thread-sleep! (random 60)) ;; we failed to get num cpus. wait a bit and try again
	  (if (> rem-tries 0)
	      (common:wait-for-normalized-load maxload msg remote-host (- rem-tries 1))
	      #f)))))

;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load
;;
(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f))
  (let* ((loadavg (common:get-cpu-load remote-host))
	 (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero.  If we get 1, it's possible that we got the previous default, and we should check again
		      (common:get-num-cpus remote-host)
		      numcpus-in))
	 (maxload (if force-maxload
		      maxload-in
		      (if (number? maxload-in)
			  (max maxload-in 0.5)
			  0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
	 (first   (car loadavg))
	 (next    (cadr loadavg))
	 (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1
	 (loadjmp (- first next))
         (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10)(/ (- 1000 count) 10) waitdelay) (- first adjload) ))  )));; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously
    ;; let's let the user know once in a long while that load checking is happening but not constantly report it
    (if (> (random 100) 75) ;; about 25% of the time
	(debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
			  ", load: " first ", adjload: " adjload ", loadjmp: " loadjmp))
    (cond
     ((and (> first adjload)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "server start delayed " adjwait " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
      (thread-sleep! adjwait)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
     ((and (> loadjmp numcpus)

	  dirpath)))

;; check space in dbdir and in megatest dir
;; returns: ok/not dbspace required-space
;;
(define (common:check-db-dir-space)
  (let* ((required (string->number 
                    ;; default is 1GB (or actually a billion bytes) This is the number of 1 kB blocks.
		    (or (configf:lookup *configdat* "setup" "dbdir-space-required")
			"1000000")))
	 (dbdir    (common:get-db-tmp-area)) ;; (db:get-dbdir))
	 (tdbspace (common:check-space-in-dir dbdir required))
	 (mdbspace (common:check-space-in-dir *toppath* required)))
    (sort (list tdbspace mdbspace) (lambda (a b)
				     (< (cadr a)(cadr b))))))
    
;; check available space in dbdir, exit if insufficient

	(begin
	  (debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace  ", exiting now.")
	  (exit 1)))))
  
;; paths is list of lists ((name path) ... )
;;
(define (common:get-disk-with-most-free-space disks minsize)
  (let* ((best     #f)
	(bestsize 0)
        (default-min-inodes-string "1000000")
        (default-min-inodes (string->number default-min-inodes-string))
        (min-inodes (or (string->number (if (configf:lookup *configdat* "setup" "min_inodes") (configf:lookup *configdat* "setup" "min_inodes") default-min-inodes-string)) default-min-inodes)))

    (for-each 
     (lambda (disk-num)
       (let* ((dirpath    (cadr (assoc disk-num disks)))
	      (freespc    (cond
			   ((not (directory? dirpath))
			    (if (common:low-noise-print 300 "disks not a dir " disk-num)
				(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it."))

			    (if (common:low-noise-print 300 "disks not a proper path " disk-num)
				(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it."))
			    -1)
			   (else
			    (get-free-inodes dirpath))))
             ;;(free-inodes (get-free-inodes dirpath))
             )
             (debug:print 2 *default-log-port* "INFO: disk " disk-num " path " dirpath " free space " freespc " free inodes " free-inodes)
	 (if (and (> freespc bestsize)(> free-inodes min-inodes ))
	     (begin
	       (set! best     (cons disk-num dirpath))
	       (set! bestsize freespc)))
        ;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes)
      ))
     (map car disks))

;;======================================================================

;;======================================================================
;; Config file handling
;;======================================================================

(use regex regex-case matchable) ;;  directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))

(include "common_records.scm")

				((getenv gv)  (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
				((mtrah)      (conc "(lambda (ht)"
                                                    "    (let ((extra \"" cmd "\"))"
						    "       (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
						    "             (if (string-null? extra) \"\" \"/\")"
						    "             extra)))"))
				((get g)   
				 (match (string-split cmd)


					((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
					(else
					 (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
					 "(lambda (ht) #f)")))
				((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				;; ((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
		;; (print "fullcmd=" fullcmd)
		(handle-exceptions
		 exn
		 (begin

    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db
     "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;"
     bdisk-id archive-path)
    (if res ;; record exists, update du if applicable and return res

	(if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
                                          WHERE archive_disk_id=? AND disk_path=?;"
				bdisk-id archive-path du))

	(begin
	  (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
                                                        VALUES (?,?,?);"
			   bdisk-id archive-path (or du 0))
	  (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))
    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
    res))


;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
;;
(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)

           #f
           #t)))))

;; given a launch delay (minimum time from last launch) return amount of time to wait
;;
;; (define (db:launch-delay-left dbstruct run-id launch-delay)
  


(define (db:get-status-from-final-status-file run-dir)
  (let (
       (infile (conc run-dir "/.final-status")))

       ;; first verify we are able to write the output file
       (if (not (file-read-access? infile))
          (begin 
	        (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
          (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
          #f
          )
          (with-input-from-file infile read-lines)
       )
  )
)




;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));

(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
  (let* ((incompleted '())
	 (oldlaunched '())
	 (toplevels   '())
          ;; The default running-deadtime is 720 seconds = 12 minutes.
          ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30))
         (deadtime-trim (or ovr-deadtime (configf:lookup-number *configdat* "setup" "deadtime")))
         (server-start-allowance 200)
         (server-overloaded-budget 200)
         (launch-monitor-off-time (or (configf:lookup-number *configdat* "setup" "test-stats-update-period") 30))
         (launch-monitor-on-time-budget 30)
         (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget))
         (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30))
         (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default))
         (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))
         (running-deadtime (or deadtime-trim running-deadtime-default)) ;; two minutes (30 seconds between updates, this leaves 3x grace period)
         )
    (debug:print-info 4  *default-log-port* "running-deadtime = " running-deadtime)
    (debug:print-info 4  *default-log-port* "deadtime-trim = " deadtime-trim)

    (db:with-db 
     dbstruct #f #f
     (lambda (db)
       ;; 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)

              (begin
                (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
                (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
              (begin
                (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))
                (debug:print-info 0 *default-log-port* "Found old test in RUNNING state, test-id=" test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time" run-duration="run-duration))))
        db
        
        "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 ('RUNNING');"
        run-id running-deadtime) ;; default time 720 seconds

       
       (sqlite3:for-each-row 
        (lambda (test-id run-dir uname testname item-path event-time run-duration)
          (if (and (equal? uname "n/a")
                   (equal? item-path "")) ;; this is a toplevel test
              ;; what to do with toplevel? call rollup?
              (begin
                (set! toplevels   (cons (list test-id run-dir uname testname item-path run-id) toplevels))
                (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
              (begin
                (debug:print-info 0 *default-log-port* "Found old test in REMOTEHOSTSTART state, test-id=" test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time" run-duration="run-duration)
                (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))))
        db
        "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');"
        run-id remotehoststart-deadtime) ;; default time 230 seconds

       ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
       ;;
       ;; (db:delay-if-busy dbdat)
       (sqlite3:for-each-row
        (lambda (test-id run-dir uname testname item-path)
          (if (and (equal? uname "n/a")

              ;;      			(or (not dbexists) ;; if no file then something wrong - mark as incomplete
              ;;      			    (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim
              ;;      		    incompleted))
              (min-incompleted-ids (map car incompleted)) ;; do 'em all
              (all-ids             (append min-incompleted-ids (map car oldlaunched))))
         (if (> (length all-ids) 0)
             (begin
	       ;; (launch:is-test-alive "localhost" 435)
               (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as DEAD")
               (for-each
                  (lambda (test-id)
                    (let* (;; (run-dir (db:test-get-rundir-from-test-id dbstruct run-id test-id))
			   (tinfo   (db:get-test-info-by-id dbstruct run-id test-id))
			   (run-dir (db:test-get-rundir     tinfo))
			   (host    (db:test-get-host       tinfo))
			   (pid     (db:test-get-process_id tinfo))
			   (result (db:get-status-from-final-status-file run-dir)))
		      (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result))) 
			  (begin
			    (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD")
			    (db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "PASS"
								   "Test stopped responding but it has PASSED; marking it PASS in the DB."))
			  (let ((is-alive (launch:is-test-alive host pid)))
			    (if is-alive
				(debug:print 0 *default-log-port* "INFO: test " test-id " on host " host " has a process on pid " pid ", NOT setting to DEAD.")
				(begin
				  (debug:print 0 *default-log-port* "INFO: test " test-id " final state/status is not COMPLETED/PASS. It is " result)
				  (db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "DEAD"
									 "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
		  all-ids)
	       ;;call end of eud of run detection for posthook
	       (launch:end-of-run-check run-id)
	       )))))))


;; ALL REPLACED BY THE BLOCK ABOVE
;;
;; 	    (sqlite3:execute 
;; 	     db
;; 	     (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN (" 
;; 		   (string-intersperse (map conc all-ids) ",")

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

Hint: You can browse the archive using bup commands directly.

----------------
bup -d /path/to/bup/archive ftp
----------------

Pass Data from Test to Test
~~~~~~~~~~~~~~~~~~~~~~~~~~~

.To save the data call archive save within your test:
----------------
megatest -archive save
----------------

.To retrieve the data call archive get using patterns as needed
----------------
# Put the retrieved data into /tmp
DESTPATH=/tmp/$USER/$MT_TARGET/$MT_RUN_NAME/$MT_TESTNAME/$MT_ITEMPATH/my_data
mkdir -p $DESTPATH
megatest -archive get -runname % -dest $DESTPATH
----------------


Submit jobs to Host Types based on Test Name
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

.In megatest.config
------------------------
[host-types]

which can launch jobs on local and remote Linux hosts. Currently
megatest uses the network filesystem to call home to your master
sqlite3 database. Megatest has been used with the Intel Netbatch and
lsf (also known as openlava) batch systems and it should be
straightforward to use it with other similar systems.</p></div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_overview">Overview</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_stand_alone_megatest_area">Stand-alone Megatest Area</h3>
<div class="paragraph"><p>A single, stand-alone, Megatest based testsuite or "area" is
sufficient for most validation, automation and build problems.</p></div>
<div class="imageblock">
<div class="content">
<img src="megatest-stand-alone-area.png" alt="Static">
</div>
</div>
<div class="paragraph"><p>Megatest is designed as a distributed or decoupled system. This means
you can run the areas stand-alone with no additional
infrastructure. I.e. there are no databases, web servers or other
centralized resources needed. However as your needs grow you can
integrate multiple areas into a bigger system.</p></div>
<div class="sect3">
<h4 id="_component_descriptions">Component Descriptions</h4>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Multi-area dashboard and xterm. A gui (the dashboard) is usually the
  best option for controlling and launching runs but all operations
  can also be done from the commandline. Note: The not yet released
  multi-area dashboard replaces the old dashboard for browsing and
  controlling runs but for managing a single area the old dashboard
  works very well.
</p>
</li>
<li>
<p>
Area/testsuite. This is your testsuite or automation definition and
  consists of the information in megatest.config, runconfigs.config
  and your testconfigs along with any custom scripting that can&#8217;t be
  done with the native Megatest features.
</p>
</li>
<li>
<p>
If your testsuite or build automation is too large to run on a
  single instance you can distribute your jobs into a compute server
  pool. The only current requirements are password-less ssh access and
  a network filesystem.
</p>
</li>
</ol></div>
</div>
</div>
<div class="sect2">
<h3 id="_full_system_architecture">Full System Architecture</h3>
<div class="imageblock">
<div class="content">
<img src="megatest-system-architecture.png" alt="Static">
</div>
</div>
</div>
</div>
</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

<div class="paragraph"><p>Hint: You can browse the archive using bup commands directly.</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>bup -d /path/to/bup/archive ftp</pre>
</div></div>
</div>
</div>
</div>
<div class="sect2">
<h3 id="_pass_data_from_test_to_test">Pass Data from Test to Test</h3>
<div class="listingblock">
<div class="title">To save the data call archive save within your test:</div>
<div class="content monospaced">
<pre>megatest -archive save</pre>
</div></div>
<div class="listingblock">
<div class="title">To retrieve the data call archive get using patterns as needed</div>
<div class="content monospaced">
<pre># Put the retrieved data into /tmp
DESTPATH=/tmp/$USER/$MT_TARGET/$MT_RUN_NAME/$MT_TESTNAME/$MT_ITEMPATH/my_data
mkdir -p $DESTPATH
megatest -archive get -runname % -dest $DESTPATH</pre>
</div></div>
</div>
<div class="sect2">
<h3 id="_submit_jobs_to_host_types_based_on_test_name">Submit jobs to Host Types based on Test Name</h3>
<div class="listingblock">
<div class="title">In megatest.config</div>
<div class="content monospaced">
<pre>[host-types]

# tabled
[itemstable]
A x y
B 1 2

# Yields x/1 y/2</pre>
</div></div>
<div class="listingblock">
<div class="title">Or use files</div>
<div class="content monospaced">
<pre>[itemopts]
slash path/to/file/with/items
# or
space path/to/file/with/items</pre>
</div></div>
<div class="listingblock">
<div class="title">File format for / delimited</div>
<div class="content monospaced">
<pre>key1/key2/key3
val1/val2/val2
...</pre>
</div></div>
<div class="listingblock">
<div class="title">File format for space delimited</div>
<div class="content monospaced">
<pre>key1 key2 key3
val1 val2 val2
...</pre>
</div></div>
</div>
<div class="sect2">
<h3 id="_requirements_section">Requirements section</h3>
<div class="listingblock">
<div class="title">Header</div>
<div class="content monospaced">
<pre>[requirements]</pre>

</div></div>
<div class="paragraph"><p>To transfer the environment to the next step you can do the following:</p></div>
<div class="listingblock">
<div class="title">Propagate environment to next step</div>
<div class="content monospaced">
<pre>$MT_MEGATEST -env2file .ezsteps/${stepname}</pre>
</div></div>
</div>
<div class="sect2">
<h3 id="_scripts">Scripts</h3>
<div class="listingblock">
<div class="title">Specifying scripts inline (best used for only simple scripts)</div>
<div class="content monospaced">
<pre>[scripts]
loaddb #!/bin/bash
  sqlite3 $1 &lt;&lt;EOF
  .mode tabs
  .import $2 data
  .q
  EOF</pre>
</div></div>
<div class="paragraph"><p>The above snippet results in the creation of an executable script
called "loaddb" in the test directory. NOTE: every line in the script
must be prefixed with the exact same number of spaces. Lines beginning
with a # will not work as expected. Currently you cannot indent
intermediate lines.</p></div>
<div class="listingblock">
<div class="title">Full example with ezsteps, logpro rules, scripts etc.</div>
<div class="content monospaced">
<pre># You can include a common file
#
[include #{getenv MT_RUN_AREA_HOME}/global-testconfig.inc]

# Use "var" for a scratch pad
#
[var]
dumpsql select * from data;
sepstr .....................................

# NOT IMPLEMENTED YET!
#
[ezsteps-addendum]
prescript something.sh
postscript something2.sh

# Add additional steps here. Format is "stepname script"
[ezsteps]
importdb loaddb prod.db prod.sql
dumpprod dumpdata prod.db "#{get var dumpsql}"
diff (echo "prod#{get var sepstr}test";diff --side-by-side \
     dumpprod.log reference.log ;echo DIFFDONE)

[scripts]
loaddb #!/bin/bash
  sqlite3 $1 &lt;&lt;EOF
  .mode tabs
  .import $2 data
  .q
  EOF

dumpdata #!/bin/bash
  sqlite3 $1 &lt;&lt;EOF
  .separator ,
  $2
  .q
  EOF

# Test requirements are specified here
[requirements]
waiton setup
priority 0

# Iteration for your test is controlled by the items section
# The complicated if is needed to allow processing of the config for the dashboard when there are no actual runs.
[items]
THINGNAME [system generatethings.sh | sort -u]

# Logpro rules for each step can be captured here in the testconfig
# note: The ;; after the stepname and the leading whitespace are required
#
[logpro]
inputdb ;;
  (expect:ignore   in "LogFileBody"  &lt; 99 "Ignore error in comments"      #/^\/\/.*error/)
  (expect:warning  in "LogFileBody"  = 0 "Any warning"                    #/warn/)
  (expect:required in "LogFileBody"  &gt; 0 "Some data found"                #/^[a-z]{3,4}[0-9]+_r.*/)

diff ;;
  (expect:ignore   in "LogFileBody"  &lt; 99 "Ignore error in comments"      #/^\/\/.*error/)
  (expect:warning  in "LogFileBody"  = 0 "Any warning"                    #/warn/)
  (expect:error    in "LogFileBody"  = 0 "&lt; or &gt; indicate missing entry"  (list #/(&lt;|&gt;)/   #/error/i))
  (expect:error    in "LogFileBody"  = 0 "Difference in data"             (list #/\s+\|\s+/ #/error/i))
  (expect:required in "LogFileBody"  &gt; 0 "DIFFDONE Marker found"          #/DIFFDONE/)
  (expect:required in "LogFileBody"  &gt; 0 "Some things found"              #/^[a-z]{3,4}[0-9]+_r.*/)

# NOT IMPLEMENTED YET!
#
## Also: enhance logpro to take list of command files: file1,file2...
[waivers]
createprod{target=%78/%/%/%} ;;
  (disable:required "DIFFDONE Marker found")
  (disable:error    "Some error")
  (expect:waive  in "LogFileBody" &lt; 99 "Waive if failed due to version" #/\w+3\.6.*/)

# test_meta is a section for storing additional data on your test
[test_meta]
author matt
owner  matt
description Compare things
tags tagone,tagtwo
reviewed never</pre>
</div></div>
</div>
<div class="sect2">
<h3 id="_triggers">Triggers</h3>
<div class="paragraph"><p>In your testconfig or megatest.config triggers can be specified</p></div>
<div class="listingblock">
<div class="title">Triggers spec</div>
<div class="content monospaced">

</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br>
Last updated 2020-07-22 14:21:46 PDT
</div>
</div>
</body>
</html>

Overview
--------

Stand-alone Megatest Area
~~~~~~~~~~~~~~~~~~~~~~~~~

A single, stand-alone, Megatest based testsuite or "area" is
sufficient for most validation, automation and build problems.

image::megatest-stand-alone-area.png[Static,300]

Megatest is designed as a distributed or decoupled system. This means
you can run the areas stand-alone with no additional
infrastructure. I.e. there are no databases, web servers or other
centralized resources needed. However as your needs grow you can
integrate multiple areas into a bigger system.

Component Descriptions
^^^^^^^^^^^^^^^^^^^^^^

. Multi-area dashboard and xterm. A gui (the dashboard) is usually the
  best option for controlling and launching runs but all operations
  can also be done from the commandline. Note: The not yet released
  multi-area dashboard replaces the old dashboard for browsing and
  controlling runs but for managing a single area the old dashboard
  works very well.
 
. Area/testsuite. This is your testsuite or automation definition and
  consists of the information in megatest.config, runconfigs.config
  and your testconfigs along with any custom scripting that can't be
  done with the native Megatest features.

. If your testsuite or build automation is too large to run on a
  single instance you can distribute your jobs into a compute server
  pool. The only current requirements are password-less ssh access and
  a network filesystem.

Full System Architecture
~~~~~~~~~~~~~~~~~~~~~~~~

image::megatest-system-architecture.png[Static,300]

[itemstable]
A x y
B 1 2

# Yields x/1 y/2
------------------

.Or use files
------------------
[itemopts]
slash path/to/file/with/items
# or
space path/to/file/with/items
------------------

.File format for / delimited
------------------
key1/key2/key3
val1/val2/val2
...
------------------

.File format for space delimited
------------------
key1 key2 key3
val1 val2 val2
...
------------------

Requirements section
~~~~~~~~~~~~~~~~~~~~

.Header
-------------------
[requirements]

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


Complex mapping example
~~~~~~~~~~~~~~~~~~~~~~~



// image::itemmap.png[]
image::complex-itemmap.png[]


We accomplish this by configuring the testconfigs of our tests C D and E as follows:

.Testconfig for Test E has
----------------------
[requirements]
waiton C

. Test A has no waitons.  All waitons of all tests in full list have been processed.  Full list is finalized.



itemstable
~~~~~~~~~~
An alternative to defining items is the itemstable section.  This lets you define the itempath in a table format rather than specifying components and relying on getting all permutations of those components.





Dynamic Flow Dependency Tree
~~~~~~~~~~~~~~~~~~~~~~~~~~~~

.Autogeneration waiton list for dynamic flow dependency trees
-------------------
[requirements]

To transfer the environment to the next step you can do the following:

.Propagate environment to next step
----------------------------
$MT_MEGATEST -env2file .ezsteps/${stepname}	  
----------------------------

Scripts
~~~~~~~

.Specifying scripts inline (best used for only simple scripts)
----------------------------
[scripts]
loaddb #!/bin/bash
  sqlite3 $1 <<EOF
  .mode tabs
  .import $2 data
  .q
  EOF
----------------------------

The above snippet results in the creation of an executable script
called "loaddb" in the test directory. NOTE: every line in the script
must be prefixed with the exact same number of spaces. Lines beginning
with a # will not work as expected. Currently you cannot indent
intermediate lines.

.Full example with ezsteps, logpro rules, scripts etc.
-----------------
# You can include a common file
#
[include #{getenv MT_RUN_AREA_HOME}/global-testconfig.inc]

# Use "var" for a scratch pad
#
[var]
dumpsql select * from data;
sepstr .....................................

# NOT IMPLEMENTED YET!
#
[ezsteps-addendum]
prescript something.sh
postscript something2.sh

# Add additional steps here. Format is "stepname script"
[ezsteps]
importdb loaddb prod.db prod.sql
dumpprod dumpdata prod.db "#{get var dumpsql}"
diff (echo "prod#{get var sepstr}test";diff --side-by-side \
     dumpprod.log reference.log ;echo DIFFDONE)

[scripts]
loaddb #!/bin/bash
  sqlite3 $1 <<EOF
  .mode tabs
  .import $2 data
  .q
  EOF

dumpdata #!/bin/bash
  sqlite3 $1 <<EOF
  .separator ,
  $2
  .q
  EOF

# Test requirements are specified here
[requirements]
waiton setup
priority 0

# Iteration for your test is controlled by the items section
# The complicated if is needed to allow processing of the config for the dashboard when there are no actual runs.
[items]
THINGNAME [system generatethings.sh | sort -u]

# Logpro rules for each step can be captured here in the testconfig
# note: The ;; after the stepname and the leading whitespace are required
#
[logpro]
inputdb ;; 
  (expect:ignore   in "LogFileBody"  < 99 "Ignore error in comments"      #/^\/\/.*error/)
  (expect:warning  in "LogFileBody"  = 0 "Any warning"                    #/warn/)
  (expect:required in "LogFileBody"  > 0 "Some data found"                #/^[a-z]{3,4}[0-9]+_r.*/)

diff ;; 
  (expect:ignore   in "LogFileBody"  < 99 "Ignore error in comments"      #/^\/\/.*error/)
  (expect:warning  in "LogFileBody"  = 0 "Any warning"                    #/warn/)
  (expect:error    in "LogFileBody"  = 0 "< or > indicate missing entry"  (list #/(<|>)/   #/error/i))
  (expect:error    in "LogFileBody"  = 0 "Difference in data"             (list #/\s+\|\s+/ #/error/i))
  (expect:required in "LogFileBody"  > 0 "DIFFDONE Marker found"          #/DIFFDONE/)
  (expect:required in "LogFileBody"  > 0 "Some things found"              #/^[a-z]{3,4}[0-9]+_r.*/)

# NOT IMPLEMENTED YET!
#
## Also: enhance logpro to take list of command files: file1,file2...
[waivers]
createprod{target=%78/%/%/%} ;;
  (disable:required "DIFFDONE Marker found")
  (disable:error    "Some error")
  (expect:waive  in "LogFileBody" < 99 "Waive if failed due to version" #/\w+3\.6.*/)

# test_meta is a section for storing additional data on your test
[test_meta]
author matt
owner  matt
description Compare things
tags tagone,tagtwo
reviewed never
-----------------

Triggers
~~~~~~~~

In your testconfig or megatest.config triggers can be specified 

.Triggers spec
-----------------

	(print "[fields]")
	(map (lambda (k)(print k " TEXT")) keys)
	(print "")
	(print "[setup]")
	(print "# Adjust max_concurrent_jobs to limit how much you load your machines")
	(print "max_concurrent_jobs 50\n")
	(print "# This is your link path. Avoid moving it once set.")
	(print "linktree " lntree) ;; (common:real-path lntree))
	(print "\n# Job tools are more advanced ways to control how your jobs are launched")
	(print "[jobtools]\nuseshell yes\nlauncher nbfake\nmaxload 1.5\n")
	(print "# You can override environment variables for all your tests here")
	(print "[env-override]\nEXAMPLE_VAR example value\n")
	(print "# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique")
	(print "[disks]\ndisk0 " firstd))) ;; (common:real-path firstd))))
    
    (print
     "==================

I'm now creating a runconfigs.config file for you with a default section.
You can use this file to set variables for your tests based on the \"target\" (the combination
of keys).

	(print "# Override settings in ../runconfigs.config for user " (current-user-name) " here.")))
    
    ;; Now create a test and logpro file
    (print
     "==================

You now have the basic common files for your megatest setup. Next run
\"megatest -create-test <testname>\" to create a test.

Thank you for using Megatest. 

You can edit your config files and create tests in the " path " directory

")))

(define (items:check-valid-items class item)
  (let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class)))
			(if s (string-split s) #f))))
    (if valid-values
	(if (member item valid-values)
	    item #f)
	item)))

;;  '(("k1" "k2" "k3")
;;    ("a" "b" "c")
;;    ("d" "e" "f"))
;;
;;    => '((("k1" "a")("k2" "b")("k3" "c"))
;;         (("k1" "d")("k2" "e")("k3" "f")))
;;
(define (items:first-row-intersperse data)
  (if (< (length data) 2)
      '()
      (let ((header (car data))
	    (rows   (cdr data)))
	(map (lambda (row)
	       (map list header row))
	     rows))))

;; k1/k2/k3
;; a/b/c
;; d/e/f
;;    => '(("k1" "k2" "k3")
;;         ("a" "b" "c")
;;         ("d" "e" "f"))
;;
;;    => '((("k1" "a")("k2" "b")("k3" "c"))
;;         (("k1" "d")("k2" "e")("k3" "f")))
;;
(define (items:read-items-file fname ftype) ;; 'sxml 'slash 'space 
  (if (and fname (file-exists? fname))
      (items:first-row-intersperse (case ftype
				     ((slash space)
				      (let ((splitter (case ftype
							((slash) (lambda (x)(string-split x "/")))
							(else    string-split))))
					(debug:print 0 *default-log-port* "Reading " fname " of type " ftype)
					(with-input-from-file fname
					  (lambda ()
					    (let loop ((inl (read-line))
						       (res '()))
					      (if (eof-object? inl)
						  res
						  (loop (read-line)(cons (splitter inl) res))))))))
				     ((sxml)(with-input-from-file fname read))
				     (else (debug:print 0 *default-log-port* "items file type " ftype " not recognised"))))
      (begin
	(if fname (debug:print 0 *default-log-port* "no items file " fname " found"))
	'())))

(define (items:get-items-from-config tconfig)
  (let* ((slashf      (configf:lookup tconfig "itemopts" "slash")) ;; a/b/c\nd/e/f\n ...
	 (sxmlf       (configf:lookup tconfig "itemopts" "sxml"))  ;; '(("a" "b" "c")("d" "e" "f") ...)
	 (spacef      (configf:lookup tconfig "itemopts" "space")) ;; a b c\nd e f\n ...
	 (have-items  (hash-table-ref/default tconfig "items"      #f))
	 (have-itable (hash-table-ref/default tconfig "itemstable" #f))
	 (items       (hash-table-ref/default tconfig "items"      '()))
	 (itemstable  (hash-table-ref/default tconfig "itemstable" '())))
    (debug:print 5 *default-log-port* "items: " items " itemstable: " itemstable)
    (set! items (map (lambda (item)
		       (if (procedure? (cadr item))
			   (list (car item)((cadr item)))  ;; evaluate the proc
			   item))
		     items))
    (set! itemstable (map (lambda (item)
			    (if (procedure? (cadr item))
				(list (car item)((cadr item)))  ;; evaluate the proc
				item))
			  itemstable))
    (if (and have-items  (null? items))     (debug:print 0 *default-log-port* "WARNING:[items] section in testconfig but no entries defined"))
    (if (and have-itable (null? itemstable))(debug:print 0 *default-log-port* "WARNNG:[itemstable] section in testconfig but no entries defined"))
    (if (or (not (null? items))
	    (not (null? itemstable))
	    slashf
	    sxmlf
	    spacef)
	(append (item-assoc->item-list items)
		(item-table->item-list itemstable)
		(items:read-items-file slashf 'slash)
		(items:read-items-file sxmlf  'sxml)
		(items:read-items-file spacef 'space))
	'(()))))

;; (pp (item-assoc->item-list itemdat))


	

  (let* ((stepname       (car ezstep))  ;; do stuff to run the step
	 (stepinfo       (cadr ezstep))
	;; (let ((info (cadr ezstep)))
	;; 		   (if (proc? info) "" info)))
	;; (stepproc       (let ((info (cadr ezstep)))
	;; 		   (if (proc? info) info #f)))
	 (stepparts      (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
	 (stepparams     (if (and (list? stepparts)
				  (> (length stepparts) 1))
			     (list-ref stepparts 2)
			     #f)) ;; for future use, {VAR=1,2,3}, run step for each
	 (paramparts     (if (string? stepparams)
			     (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))
			     '()))
	 (subrun         (alist-ref "subrun" paramparts equal?))
	 (stepcmd        (if (and (list? stepparts)
				  (> (length stepparts) 2))
			     (list-ref stepparts 3)
			     (conc "# error, no command for step "stepname)))
	 (script         "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\
	 (logpro-file    (conc stepname ".logpro"))
	 (html-file      (conc stepname ".html"))
	 (dat-file       (conc stepname ".dat"))
	 (tconfig-logpro (configf:lookup testconfig "logpro" stepname))
	 (logpro-used    (common:file-exists? logpro-file)))

	    (set-signal-handler! signal/int sighand)
	    (set-signal-handler! signal/term sighand)
	    ) ;; (set-signal-handler! signal/stop sighand)
	  
	  ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART,
	  ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY*
	  ;;
	  (let* ((test-info (let loop ((tries 0))
			      (let ((tinfo (rmt:get-test-info-by-id run-id test-id)))
				(if tinfo
				    tinfo
				    (if (> tries 5)
					#f
					(begin
					  (thread-sleep! (+ 1 (* tries 10)))
					  (loop (+ tries 1))))))))
		 (test-host (if test-info
				(db:test-get-host        test-info)
				(begin
				  (debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.")
				  (exit))))
		 (test-pid  (db:test-get-process_id  test-info)))
	    (cond

	  ;; We are about to actually kick off the test
	  ;; so this is a good place to remove the records for 
	  ;; any previous runs
	  ;; (db:test-remove-steps db run-id testname itemdat)
	  ;; now is also a good time to write the .testconfig file
	  (let* ((tconfig-fname   (conc work-area "/.testconfig"))
		 (tconfig-tmpfile (conc tconfig-fname ".tmp"))
		 (tconfig         (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
		 (scripts (configf:get-section tconfig "scripts")))
	    ;; create .testconfig file
	    (configf:write-alist tconfig tconfig-tmpfile)
	    (file-move tconfig-tmpfile tconfig-fname #t)
	    (delete-file* ".final-status")

	    ;; extract scripts from testconfig and write them to files in test run dir
	    (for-each
	     (lambda (scriptdat)
	       (match scriptdat
		      ((name content)
		       (with-output-to-file name
			 (lambda ()
			   (print content)
			   (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))))
		      (else
		       (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
	     scripts))
	  ;; 
	  (let* ((m            (make-mutex))
		 (kill-job?    #f)
		 (exit-info    (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
		 (job-thread   #f)
		 ;; (keep-going   #t)
		 (misc-flags   (let ((ht (make-hash-table)))

				      (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN"))
				     ((eq? (launch:einf-rollup-status exit-info) 3) "CHECK")
				     ((eq? (launch:einf-rollup-status exit-info) 4) "WAIVED")
				     ((eq? (launch:einf-rollup-status exit-info) 5) "ABORT")
				     ((eq? (launch:einf-rollup-status exit-info) 6) "SKIP")
				     (else "FAIL")))) ;; (db:test-get-status testinfo)))
		    (debug:print-info 1 *default-log-port* "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info))
   
        ;; Leave a .final-status file for each sub-test
        (tests:save-final-status run-id test-id)

		    (tests:test-set-status! run-id 
					    test-id 
					    new-state
					    new-status
					    (args:get-arg "-m") #f)
		    ;; need to update the top test record if PASS or FAIL and this is a subtest
		    ;; NO NEED TO CALL set-state-status-and-roll-up-items HERE, THIS IS DONE IN set-state-status-and-roll-up-items called by tests:test-set-status!
		    ))
	      ;; for automated creation of the rollup html file this is a good place...
	      (if (not (equal? item-path ""))
		      (tests:summarize-items run-id test-id test-name #f))
	      (tests:summarize-test run-id test-id)  ;; don't force - just update if no
        ;; Leave a .final-status file for the top level test
        (tests:save-final-status run-id test-id)
	      (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
	    (mutex-unlock! m)
            (launch:end-of-run-check run-id )
	    (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " 
			 work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
	    (if (not (launch:einf-exit-status exit-info))
		(exit 4))))

(define (launch:end-of-run-check run-id )
    (let*	((not-completed-cnt (rmt:get-not-completed-cnt run-id))  
           (running-cnt (rmt:get-count-tests-running-for-run-id run-id))
           (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id)))
           (current-state (rmt:get-run-state run-id))
           (current-status (rmt:get-run-status run-id)))
     ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing 
     (debug:print 0 *default-log-port* "Running test cnt :" running-cnt)                      
     (rmt:set-state-status-and-roll-up-run  run-id current-state current-status)
     (runs:update-junit-test-reporter-xml run-id) 
     (cond 
       ((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" ))
                (if (and (equal? (rmt:get-var (conc "end-of-run-" run-id)) "no") (common:simple-lock (conc "endOfRun" run-id)))
                (begin
           	(debug:print 4 *default-log-port* "look for  post hook. currseconds: " (current-seconds) " EOR " (rmt:get-var (conc "end-of-run-" run-id)))
                (debug:print 0 *default-log-port* "End of Run Detected.")
                (rmt:set-var (conc "end-of-run-" run-id) "yes")
                ;(thread-sleep! 10)
          	(runs:run-post-hook run-id)
                (debug:print 4 *default-log-port* "currseconds: " (current-seconds)" eor: " (rmt:get-var (conc "end-of-run-" run-id)))
                (common:simple-unlock (conc "endOfRun" run-id)))
                 (debug:print 0 *default-log-port* "End of Run Detected but not running post hook. This should happen when eor is set to yes. This will happen only when 2 tests exit at smae time. eor= " (rmt:get-var (conc "end-of-run-" run-id)))))
        ((> running-cnt 3) 
        	  (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" "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" "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))

(define (launch:setup-body #!key (force-reread #f) (areapath #f))
  (if (and (eq? *configstatus* 'fulldata)
	   *toppath*
	   (not force-reread)) ;; no need to reprocess
      *toppath*   ;; return toppath
      (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting.  We do not have *configdat*.  Bootstrapping problem here.
	     (toppath  (common:get-toppath areapath))
	     (target   (common:args-get-target))
	     (sections (if target (list "default" target) #f)) ;; for runconfigs
	     (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config 
             (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
	     ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ...
	     (mtcachef   (if (null? cachefiles)
			     #f

		  (set! toppath      *toppath*)
		  (if (not *toppath*)
		      (begin
			(debug:print-error 0 *default-log-port* "you are not in a megatest area!")
			(exit 1)))
		  (setenv "MT_RUN_AREA_HOME" *toppath*)
		  ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
		  (let* ((keys         (common:list-or-null (rmt:get-keys)
							    message: "Failed to retrieve keys in launch.scm. Please report this to the developers."))
			 (key-vals     (keys:target->keyval keys target))
			 (linktree     (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
					;     (if *configdat*
					; 	   (configf:lookup *configdat* "setup" "linktree")
					; 	   (conc *toppath* "/lt"))))
			 (second-pass  (find-and-read-config
					mtconfig

	;; if have -append-config then read and append here
	(let ((cfname (args:get-arg "-append-config")))
	  (if (and cfname
		   (file-read-access? cfname))
	      (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special.
	*toppath*)))


(define (get-best-disk confdat testconfig)
  (let* ((disks   (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
		      (hash-table-ref/default confdat "disks" #f)))
	 (minspace (let ((m (configf:lookup confdat "setup" "minspace")))
		     (string->number (or m "10000")))))
    (if disks 
	(let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb
	  (if res
	      (cdr res)
	      (begin ;; DEAD CODE PATH - REVISIT!
;;		(if (common:low-noise-print 20 "No valid disks or no disk with enough space")
;;		    (debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n    You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace))
		;;(exit 1)
                 (if (null? disks)
                     (cons 1 (conc *toppath* "/runs"))
                     (let ((paths (sort disks (lambda (x y) (> (string-length (cadr x)) (string-length (cadr y)))))))
                       (let loop ((head (car paths)) (tail (cdr paths)))
                         (let ((result (handle-exceptions exn #f (create-directory (cadr head) #t))))
                           (if result
                               result
                               (if (null? tail)
                                   (cons 1 (conc *toppath* "/runs"))
                                   (loop (car tail) (cdr tail)))))))))))
	;; no disks definition - use mtrah/runs, fall back to currdir/runs
	(let* ((toppath (or *toppath*
			    (common:get-toppath *toppath*)
			    (begin
			      (debug:print-error 0 *default-log-port* "Creating runs dir in current directory, this is probably not what you wanted. Please check your setup.")
			      (current-directory))))
	       (runsdir (conc toppath "/runs")))
	  (if (not (file-exists? runsdir))(create-directory runsdir))
	  runsdir)
	))) ;; the code creates the necessary directories if it does not exist and returns the path.

(define (launch:test-copy test-src-path test-path)
  (let* ((ovrcmd (let ((cmd (configf:lookup *configdat* "setup" "testcopycmd")))
		   (if cmd
		       ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
		       (string-substitute "TEST_TARG_PATH" test-path
					  (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)

    ;; level
    (if (not not-iterated) ;; i.e. iterated
	(let ((iterated-parent  (pathname-directory (conc lnkpath "/" item-path))))
	  (debug:print-info 2 *default-log-port* "Creating iterated parent " iterated-parent)
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print-error 0 *default-log-port* " Failed to create directory " iterated-parent ((condition-property-accessor 'exn 'message) exn) ", continuing but link tree may be corrupted")
	     #;(exit 1))
	   (create-directory iterated-parent #t))))

    (if (symbolic-link? lnkpath) 
	(handle-exceptions
	 exn
	 (begin
	   (debug:print-error 0 *default-log-port* " Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", continuing but link tree may be corrupted.")
	   #;(exit 1))
	 (delete-file lnkpath)))

    (if (not (or (common:file-exists? lnkpath)
		 (symbolic-link? lnkpath)))
	(handle-exceptions
	 exn
	 (begin
	   (debug:print-error 0 *default-log-port* " Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", continuing but link tree may be corrupted.")
	   #;(exit 1))
	 (create-symbolic-link toptest-path lnkpath)))
    
    ;; NB - This was not working right - some top tests are not getting the path set!!!
    ;;
    ;; Do the setting of this record after the paths are created so that the shortdir can 
    ;; be set to the real directory location. This is safer for future clean up if the link
    ;; tree is damaged or lost.

;;     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.6558)

# short areas=fullrun,ext-tests; selector=MAXPATT/
# all   areas=fullrun,ext-tests
# snazy selector=QUICKPATT/

[nopurpose]

[access]
ext #{getenv USER}:admin matt:admin mattw:owner

[accesstypes]
admin run rerun resume remove set-ss rerun-clean
owner run rerun resume remove rerun-all
badguy set-ss

[setup]

  -refdb2dat refdb        : convert refdb to sexp or to format specified by s-dumpmode
                            formats: perl, ruby, sqlite3, csv (for csv the -o param
                            will substitute %s for the sheet name in generating 
                            multiple sheets)
  -o                      : output file for refdb2dat (defaults to stdout)
  -archive cmd            : archive runs specified by selectors to one of disks specified
                            in the [archive-disks] section.
                            cmd: keep-html, restore, save, save-remove, get (use 
                            -dest to set destination), -include path1,path2... to get or save specific files
  -generate-html          : create a simple html dashboard for browsing your runs
  -generate-html-structure  : create a top level html veiw to list targets/runs and a Run view within each run directory.  
  -list-run-time          : list time requered to complete runs. It supports following switches
                            -run-patt <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
  -list-test-time	   : list time requered to complete each test in a run. It following following arguments
                            -runname <patt> -target <patt> -dumpmode <csv,json,plain-text>

			"-logpro"
			"-m"
			"-rerun"

			"-days"
			"-rename-run"
			"-to"
			"-dest"
			;; values and messages
			":category"
			":variable"
			":value"
			":expected"
			":tol"
			":units"

			"-setvars"
			"-set-state-status"

                        ;; move runs stuff here
                        "-remove-keep"           
			"-set-run-status"
			"-age"

			;; archive 
			"-archive"
			"-actions"
			"-precmd"
			"-include"
			"-exclude-rx"
			"-exclude-rx-from"
			
			"-debug" ;; for *verbosity* > 2
			"-create-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all
			"-load"        ;; load and exectute a scheme file
			"-section"

       (start-watchdog (null? no-watchdog-args-vals)))
  ;;(BB> "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals) 
  (if start-watchdog
      (thread-start! *watchdog*)))


;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath-in)
  (condition-case
   (let* ((log-dir (or (pathname-directory logpath-in) "."))
	  (fname   (pathname-strip-directory logpath-in))
	  (logpath (if (> (string-length fname) 250)
		       (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
			 (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
			 newlogf)
		       logpath-in)))
     (if (not (directory-exists? log-dir))
         (system (conc "mkdir -p " log-dir)))
     (open-output-file logpath))
   (exn ()
        (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
        (define *didsomething* #t)  
        (exit 1))))

;;======================================================================
;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
  (let* ((runrec (runs:runrec-make-record))
	 (target (or target-in   (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
	 (runname (or runname-in
		      (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
	 (testpatt (or (args:get-arg "-testpatt")
		       (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
			    (common:get-full-test-name))
		       (and (eq? action 'kill-runs)
			    "%/%") ;; I'm just guessing that this is correct :(
		       (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")))
		       ))) ;;
    (cond
     ((not target)
      (debug:print-error 0 *default-log-port* "Missing required parameter for "
			 action ", you must specify -target or -reqtarg")
      (exit 1))

     ((not runname)
      (debug:print-error 0 *default-log-port* "Missing required parameter for "
			 action ", you must specify the run name pattern with -runname patt")
      (exit 2))
     ((not testpatt)
      (debug:print-error 0 *default-log-port* "Missing required parameter for "
			 action ", you must specify the test pattern with -testpatt")
      (exit 3))
     (else
      (if (not (car *configinfo*))
	  (begin
	    (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
	    (exit 1))
	  ;; put test parameters into convenient variables
	  (begin
	    ;; check for correct version, exit with message if not correct
	    (common:exit-on-version-changed)
	    (runs:operate-on  action
			      target
			      runname
			      testpatt
			      state:  (common:args-get-state)
			      status: (common:args-get-status)
			      new-state-status: (args:get-arg "-set-state-status")
                              mode: mode)))
      (set! *didsomething* #t)))))

(if (args:get-arg "-kill-runs")
    (general-run-call 

;;       (print (sort run-ids <))
;;       (set! *didsomething* #t)))
      
      
;;======================================================================
;; full run
;;======================================================================

(define (handle-run-requests target runname keys keyvals need-clean)	 
  (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
      ;; For rerun-clean do we or do we not support the testpatt?
      (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
			  "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
	    (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
			  "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
	(hash-table-set! args:arg-hash "-preclean" #t)
	(runs:operate-on 'set-state-status
			 target
			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			 state:  states
			 ;; status: statuses
			 new-state-status: "NOT_STARTED,n/a")
	(runs:clean-cache target runname *toppath*)
	(runs:operate-on 'set-state-status
			 target
			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			 ;; state:  states
			 status: statuses
			 new-state-status: "NOT_STARTED,n/a")))
  ;; RERUN ALL
  (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
      (let* ((rconfig (full-runconfigs-read)))
	(hash-table-set! args:arg-hash "-preclean" #t)
	(runs:operate-on 'set-state-status
			 target
			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
			 state:  #f
			 ;; status: statuses
			 new-state-status: "NOT_STARTED,n/a")
	(runs:clean-cache target runname *toppath*)
	(runs:operate-on 'set-state-status
			 target
			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
			 ;; state:  states
			 status: #f
			 new-state-status: "NOT_STARTED,n/a")))
  (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
			       (if x (string->number x) #f)))
	 (rerun-cnt (if config-reruns
			config-reruns
			1)))

    (runs:run-tests target
		    runname
		    #f ;; (common:args-get-testpatt #f)
		    ;; (or (args:get-arg "-testpatt")
		    ;;     "%")
		    user
		    args:arg-hash
		    run-count: rerun-cnt)))

;; get lock in db for full run for this directory
;; for all tests with deps
;;   walk tree of tests to find head tasks
;;   add head tasks to task queue
;;   add dependant tasks to task queue 
;;   add remaining tasks to task queue

(if (or (args:get-arg "-runall")
	(args:get-arg "-run")
	(args:get-arg "-rerun-clean")
	(args:get-arg "-rerun-all")
	(args:get-arg "-runtests")
        (args:get-arg "-kill-rerun"))
    (let ((need-clean (or (args:get-arg "-rerun-clean")
                          (args:get-arg "-rerun-all")))
	  (orig-cmdline (string-intersperse (argv) " ")))
      (general-run-call 
       "-runall"
       "run all tests"
       (lambda (target runname keys keyvals)








	 (if (or (string-search "%" target)






		 (string-search "%" runname)) ;; we are being asked to re-run multiple runs

	     (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records
	       (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with "







				 (length run-specs) " matches round. Running each in turn.")
	       (if (null? run-specs)
		   (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname))
	       (for-each (lambda (spec) 
			   (let* ((newcmdline (string-substitute


					       (conc "target " target)







					       (conc "target " (simple-run-target spec))






					       (string-substitute
						(conc "runname " runname)
						(conc "runname " (simple-run-runname spec))
						orig-cmdline))))
			     (debug:print 0 *default-log-port* "ORIG: " orig-cmdline)
			     (debug:print 0 *default-log-port* "NEW:  " newcmdline)
			     (system newcmdline)))
			 run-specs))





	     (handle-run-requests target runname keys keyvals need-clean))))))

;;======================================================================
;; run one test
;;======================================================================

;; 1. find the config file
;; 2. change to the test directory

;;======================================================================
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
(if (args:get-arg "-archive")
    ;; else do a general-run-call
    (begin
      ;; for the archive get we need to preserve the starting dir as part of the target path
      (if (and (args:get-arg "-dest")
	       (not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
	  (let ((newpath  (conc (current-directory) "/" (args:get-arg "-dest"))))
	    (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath)
	    (hash-table-set! args:arg-hash "-dest" newpath)))
      (general-run-call 
       "-archive"
       "Archive"
       (lambda (target runname keys keyvals)
	 (operate-on 'archive target-in: target runname-in: runname )))))

;;======================================================================
;; Extract a spreadsheet from the runs database
;;======================================================================

(if (args:get-arg "-extract-ods")
    (general-run-call

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(use srfi-1 posix srfi-69 readline ;;  regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
   srfi-19  srfi-18 extras format pkts regex regex-case
     (prefix dbi dbi:)
     (prefix sqlite3 sqlite3:)
     nanomsg)

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))

    ("-log"             . #f)
    ("-override-user"   . #f)
    ("-msg"             . M)
    ("-start-dir"       . S)
    ("-set-vars"        . v)
    ("-config"          . h)
    ("-time-out"        . u)
    ("-archive"         . b)
    ))
(define *switch-keys*
  '(
    ("-h"               . #f)
    ("-help"            . #f)
    ("--help"           . #f)
    ("-manual"          . #f)

    (rerun-clean . "-rerun-clean")
    (rerun-all   . "-rerun-all")
    (kill-run    . "-kill-runs")
    (kill-rerun  . "-kill-rerun")
    (lock        . "-lock")
    (unlock      . "-unlock")
    (sync        . "")
    (archive     . "")
    (set-ss      . "-set-state-status")
    (remove      . "-remove-runs")))

;; manually keep this list updated from the keys to
;; the case *action* near the end of this file.
(define *other-actions*
  '(run remove rerun set-ss archive kill list

	      (rgconf    (car rgconfdat))
	      (all-areas (map car (configf:get-section mtconf "areas")))
	      (contours  (configf:get-section mtconf "contours"))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )
	      (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering

	 ;;(print "rgentargs: " rgentargs)

	  (for-each
	  (lambda (runkey)
	    (let* ((keydats   (configf:get-section rgconf runkey)))
	      (for-each
	       (lambda (sense) ;; these are the sense rules
		 (let* ((key        (car sense))
			(val        (cadr sense))
			(keyparts   (string-split key ":")) ;; contour:ruletype:action:optional

       (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
	      (rgconf    (car rgconfdat))
	      (areas     (configf:get-section mtconf "areas"))
	      (contours  (configf:get-section mtconf "contours"))
	      (pkts      (find-pkts pdb '(cmd) '()))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )
	      (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
         (sqlite3:set-busy-handler! (dbi:db-conn pdb) (sqlite3:make-busy-timeout 10000))
	 (for-each
	  (lambda (pktdat)
	    (let* ((pkta    (alist-ref 'apkt pktdat))
		   (action  (alist-ref 'A pkta))
		   (cmdline (pkt->cmdline pkta))
		   (uuid    (alist-ref 'Z pkta))
		   (user    (alist-ref 'U pkta))

      (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
    
  (cond
   ((> attemptnum 2) (thread-sleep! 0.05))
   ((> attemptnum 10) (thread-sleep! 0.5))
   ((> attemptnum 20) (thread-sleep! 1)))
  (if (and (> attemptnum 5) (= 0 (modulo attemptnum 15)))  
    (begin (server:run *toppath*) (thread-sleep! 3))) 
  
  
  ;;DOT digraph megatest_state_status {
  ;;DOT   ranksep=0;
  ;;DOT   // rankdir=LR;
  ;;DOT   node [shape="box"];
  ;;DOT "rmt:send-receive" -> MUTEXLOCK;

;;

(define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)
  ;; (mutex-unlock! *rmt-mutex*)
  (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9")
  ;; (mutex-lock! *rmt-mutex*)
  (let* ((conninfo (remote-conndat runremote))
	 (dat-in      (case (remote-transport runremote)
		     ((http) (condition-case ;; handling here has
					     ;; caused a lot of
					     ;; problems. However it
					     ;; is needed to deal with
					     ;; attemtped
					     ;; communication to
					     ;; servers that have gone
					     ;; away
			      (http-transport:client-api-send-receive 0 conninfo cmd params)
			      ((commfail)(vector #f "communications fail"))
			      ((exn)(vector #f "other fail" (print-call-chain)))))
		     (else
		      (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported")
		      (exit))))

;; No Title 
;; Error: (vector-ref) out of range
;; #(#<condition: (exn type)> (#("db.scm:3740: regex#regexp" #f #f) #("db.scm:3739: regex#string-substitute" #f #f) #("db.scm:3738: base64#base64-decode" #f #f) #("db.scm:3737: z3#z3:decode-buffer" #f #f) #("db.scm:3736: with-input-from-string" #f #f) #("db.scm:3741: s11n#deserialize" #f #f) #("api.scm:374: api:execute-requests" #f #f) #("api.scm:139: call-with-current-continuation" #f #f) #("api.scm:139: with-exception-handler" #f #f) #("api.scm:139: ##sys#call-with-values" #f #f) #("api.scm:158: string->symbol" #f #f) #("api.scm:160: current-milliseconds" #f #f) #("api.scm:161: dbr:dbstruct-read-only" #f #f) #("api.scm:139: k15" #f #f) #("api.scm:139: g19" #f #f) #("api.scm:142: get-call-chain" #f #f)) #("get-test-info-by-id" (1102 507299)))
;; 6
;; 
;; 	Call history:
;; 
;; 	http-transport.scm:306: thread-terminate!	  
;; 	http-transport.scm:307: debug:print-info	  
;; 	common_records.scm:235: debug:debug-mode	  
;; 	rmt.scm:259: k587	  
;; 	rmt.scm:259: g591	  
;; 	rmt.scm:276: http-transport:server-dat-update-last-access	  
;; 	http-transport.scm:364: current-seconds	  
;; 	rmt.scm:282: debug:print-info	  
;; 	common_records.scm:235: debug:debug-mode	  
;; 	rmt.scm:283: mutex-unlock!	  
;; 	rmt.scm:287: extras-transport-succeded	  	<--
;; +-----------------------------------------------------------------------------+
;; | Exit Status    : 70  
;;  

	 (dat      (if (and (vector? dat-in) ;; ... check it is a correct size
			    (> (vector-length dat-in) 1))
		       dat-in
		       (vector #f (conc "communications fail (type 2), dat-in=" dat-in))))
	 (success  (if (vector? dat) (vector-ref dat 0) #f))
	 (res      (if (vector? dat) (vector-ref dat 1) #f)))
    (if (and (vector? conninfo) (< 5 (vector-length conninfo)))
	(http-transport:server-dat-update-last-access conninfo) ;; refresh access time
	(begin
	  (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo)
	  (set! conninfo #f)

#    sudo apt install emacs-goodies-el
# Add to your ~/.emacs file:
#    (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode))
#

# example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config
#
[a/b/c/d]
all:scheduled:sync     cron=  0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config
# quick:scheduled:sync   cron=  0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config
# fast:scheduled:sync-prepend cron=  0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config

[scriptinc ./gentargets.sh #{getenv USER}]
# [v1.23/45/67]

;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
     posix-extras directory-utils pathname-expand typed-records format  sxml-serializer sxml-modifications)

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))

(define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)

  ;; Take advantage of a good place to exit if running the one-pass methodology
  (if (and (> (runs:dat-can-run-more-tests-count runsdat) 20)
	   (args:get-arg "-one-pass"))
      (exit 0))

  (thread-sleep! (cond ;; BB: check with Matt.  Should this sleep move
		       ;; to cond clauses below where we determine we
		       ;; have too many jobs running rather than each
		       ;; time the and condition above is true (which
		       ;; seems like always)?
        	  ((> (runs:dat-can-run-more-tests-count runsdat) 20) ;; original intent was - save cycles, wait a long time
		   (if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ..."))

		   10)  ;; obviously haven't had any work to do for a while
		  (else
		   ;; if have a number for inter-test-delay, use it, else don't delay much, maybe even zero?
		   (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.01))))
  
  (let* ((num-running             (rmt:get-count-tests-running run-id))
	 (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
	 (job-group-limit         (let ((jobg-count (configf:lookup *configdat* "jobgroups" jobgroup)))
				    (if (string? jobg-count)
					(string->number jobg-count)
					jobg-count))))

    (runs:update-all-test_meta #f)

    ;; run the run prehook if there are no tests yet run for this run:
    ;;
    (runs:run-pre-hook run-id)
    ;; mark all test launced flag as false in the meta table 
    (rmt:set-var (conc "lunch-complete-" run-id) "no")
    (debug:print-info 1 *default-log-port* "Setting end-of-run to no")
    (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
			       (if x (string->number x) #f)))
	  (config-rerun-cnt (if config-reruns
			config-reruns
			1)))
    (if (eq? config-rerun-cnt run-count)
      (rmt:set-var (conc "end-of-run-" run-id) "no")))

    (rmt:set-run-state-status run-id "new" "n/a")
    ;; now add non-directly referenced dependencies (i.e. waiton)
    ;;======================================================================
    ;; refactoring this block into tests:get-full-data
    ;;
    ;; What happended, this code is now duplicated in tests!?
    ;;

	    (if (> run-count 0) ;; handle reruns
		(begin
		  (if (not (hash-table-ref/default flags "-preclean" #f))
		      (hash-table-set! flags "-preclean" #t))
		  (if (not (hash-table-ref/default flags "-rerun" #f))
		      (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS"))
		  ;; recursive call to self
      (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))
                  (launch:end-of-run-check run-id)))
	  (debug:print-info 0 *default-log-port* "No tests to run")))
    (debug:print-info 4 *default-log-port* "All done by here")
    ;; TODO: try putting post hook call here
      


    ;  (debug:print-info 2 *default-log-port* " run-count " run-count)
    ;  (runs:run-post-hook run-id))
    ;  (debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count ))   
    (rmt:tasks-set-state-given-param-key task-key "done")
     
    ;; (sqlite3:finalize! tasks-db)
    ))


;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable.
;;
;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns

  (let ((curr-sec (current-seconds)))
    (if (> (- curr-sec (runs:gendat-inc-results-last-update *runs:general-data*)) 5) ;; at least five seconds since last update
	(let* ((run-dat  (or (runs:gendat-run-info *runs:general-data*)(rmt:get-run-info run-id)))
	       (runname  (or (runs:gendat-runname *runs:general-data*)
			     (db:get-value-by-header (db:get-rows run-dat)
						     (db:get-header run-dat) "runname")))
	       (target   (or (runs:gendat-target *runs:general-data*)(rmt:get-target run-id)))
	       (testsdat (let ((res (rmt:get-tests-for-run
				     run-id "%" '() '() ;; run-id testpatt states statuses
				     #f #f ;; offset limit
				     #f ;; not-in
				     #f ;; sort-by
				     #f ;; sort-order
				     #f ;; get full data (not 'shortlist)
				     (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
				     'dashboard)))
			   (if (list? res)
			       res
			       (begin
				 (debug:print-error
				  0 *default-log-port*
				  "FAILED TO GET DATA using rmt:get-tests-for-run. Notify developers if you see this. result: " res)
				 '())))))
	  (if (not (runs:gendat-run-info *runs:general-data*))
	      (runs:gendat-run-info-set! *runs:general-data* run-dat))
	  (if (not (runs:gendat-runname  *runs:general-data*))
	      (runs:gendat-runname-set! *runs:general-data* runname))
	  (if (not (runs:gendat-target *runs:general-data*))
	      (runs:gendat-target-set! *runs:general-data* target))
	  (for-each

	  (debug:print-info 0 *default-log-port* "Have leftovers!")
	  (loop (car reg)(cdr reg) '() reruns))
	 (else
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-9")
	  (debug:print-info 4 *default-log-port* "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
	 ))) ;; end loop on sorted test names
    ;; this is the point where everything is launched and now you can mark the run in metadata table as all launched 
    (rmt:set-var (conc "lunch-complete-" run-id) "yes")  
        
    ;; now *if* -run-wait we wait for all tests to be done
    ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
    (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
    (let wait-loop ((num-running      (rmt:get-count-tests-running-for-run-id run-id))
		    (prev-num-running 0))
      ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running)
      (if (and (or (args:get-arg "-run-wait")

  ;; then files other than *testdat.db*
  (directory-fold 
   (lambda (f x)
     (let ((fullname (conc real-dir "/" f)))
       (if (not (string-search (regexp "testdat.db") f))
	   (runs:recursive-delete-with-error-msg fullname)))
     (+ 1 x))
   0 real-dir #t)
  ;; then the entire directory
  (runs:recursive-delete-with-error-msg real-dir))

;; cleanup often needs to remove all but the last N runs per target
;;
;; target-patts a1/b1/c1,a2/b2/c2 ...
;;

			))
		   actions))))
          sorted)))
     ;; (print "Sorted: " (map simple-run-event_time sorted))
     ;; (print "Remove: " (map simple-run-event_time to-remove))))
     (hash-table-keys runs-ht))
    runs-ht))

(define (remove-last-path-directory path-in)
  (let* ((dparts  (string-split path-in "/"))
    (path-out (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))
    )
    path-out
  )
)


;; (define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep)
;;   (let ((data (runs:get-all-but-most-recent-n-per-target target-patts runpatt num-to-keep)))
;;     (for-each
;;      (lambda (target)
;;        (let ((runs-to-remove (hash-table-ref data target )))
;;          (for-each

	 (header       (vector-ref rundat 0))
	 (runs         (vector-ref rundat 1))
	 (states       (if state  (string-split state  ",") '()))
	 (statuses     (if status (string-split status ",") '()))
	 (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))
	 (rp-mutex     (make-mutex))
	 (bup-mutex    (make-mutex))
         (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".
	 (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop

    (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs))
           (dbfile             (conc  *toppath* "/megatest.db"))
           (readonly-mode      (not (file-write-access? dbfile))))
      (when (and readonly-mode
                 (member action write-access-actions))
        (debug:print-error 0 *default-log-port* "megatest.db is readonly.  Cannot proceed with action ["action"] in which write-access isrequired .")

	 (let* ((run-id    (db:get-value-by-header run header "id"))
		(run-state (db:get-value-by-header run header "state"))
		(run-name  (db:get-value-by-header run header "runname"))
		(tests     (if (not (equal? run-state "locked"))
			       (proc-get-tests run-id)
			       '()))
		(lasttpath "/does/not/exist/I/hope")
		(lastrealpath "/does/not/exist/I/hope")
                ;; there may be a number of different disks used in the same run.
                (run-paths-hash (make-hash-table))
		(worker-thread #f))
	   (debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header)
	   (if (not (null? tests))
	       (begin
		 (case action
                   ((kill-runs)
                    (tasks:kill-runner target run-name "%")

		   ((print-run)
		    (debug:print 1 *default-log-port* "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
		    action)
		   ((run-wait)
		    (debug:print 1 *default-log-port* "Waiting for run " runkey ", run=" runnamepatt " to complete"))
		   ((archive)
		    (debug:print 1 *default-log-port* "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname"))
		    (let ((op (string->symbol (args:get-arg "-archive"))))
		      (set! worker-thread
			    (make-thread
			     (lambda ()
			       (case op
				 ((save save-remove keep-html)
				  (archive:run-bup op run-id run-name tests rp-mutex bup-mutex))
				 ((restore)
				  (archive:bup-restore op run-id run-name tests rp-mutex bup-mutex))
				 ((get) ;;; NOTE: This is a special case. We wish to operate on ALL tests in one go
				  (set! test-records (append tests test-records)))
				 (else 
				  (debug:print-error 0 *default-log-port* "unrecognised sub command " op " for -archive. Run \"megatest\" to see help")
				  (exit))))
			     "archive-bup-thread"))
		      (thread-start! worker-thread)
		      (if (eq? op 'get)
			  (thread-join! worker-thread)) ;; we need the test-records set to not overlap
		      ))
		   (else
		    (debug:print-info 0 *default-log-port* "action not recognised " action)))
		 
		 ;; actions that operate on one test at a time can be handled below
		 ;;
		 (let ((sorted-tests     (filter 
					  vector?

                                              (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
                                              (thread-sleep! 1)))
                                        ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ...
                                        (if (null? tal)
                                            (loop new-test-dat tal)
                                            (loop (car tal)(append tal (list new-test-dat)))))
                                      (begin
                                       (let ((rundir (db:test-get-rundir new-test-dat)))
                                        (if (and (not (string=  rundir "/tmp/badname")) 
                                             (file-exists? rundir)
                                             (substring-index run-name rundir)
                                             (substring-index target rundir)
                                             )
                                          (begin
                                            (set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal
                                            (set! lastrealpath (remove-last-path-directory (resolve-pathname lasttpath)))
                                            (hash-table-set! run-paths-hash lastrealpath 1)
                                            (runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
                                          )
                                          (begin
                                            (debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name")
                                            (debug:print 2 *default-log-port* "Is /tmp/badname: " (string=  rundir "/tmp/badname"))
                                            (debug:print 2 *default-log-port* "Exists: " (file-exists? rundir))
                                            (debug:print 2 *default-log-port* "Has run-name: " (substring-index run-name rundir))
                                            (debug:print 2 *default-log-port* "Has target: " (substring-index target rundir))
                                            ;;PJH remove record from db no need to cleanup directory
                                            (case mode
                                               ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f))
                                               ((archive-remove)  (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f))
                                               (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))

                                          )
                                        )
                                      )

                                      (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" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")))
                                  (common:send-thunk-to-background-thread

					     (debug:print-info 0 *default-log-port* "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir)))))))
				(if (not (null? tal))
				    (loop (car tal)(cdr tal))))
			       )))
		       )
		     (if worker-thread (thread-join! worker-thread)))
                   (common:join-backgrounded-threads))))
	   
	   ;; remove the run if zero tests remain
	   (if (eq? action 'remove-runs)
	       (let* ((run-id   (db:get-value-by-header run header "id")) ;; NB// masks run-id from above?
                      (remtests (mt:get-tests-for-run run-id #f '("DELETED") '("n/a") not-in: #t)))
		 (if (null? remtests) ;; no more tests remaining
	           (let* ((linkspath (remove-last-path-directory lasttpath))
                          (runpaths (hash-table-keys run-paths-hash))
                    )

                    (debug:print 2 *default-log-port* "run-paths-hash: " (hash-table-keys run-paths-hash))

                    (debug:print 1 *default-log-port* "Removing target " target "run: " run-name)
                    (if (not keep-records)
                      (begin
                        (debug:print 1 *default-log-port* "Removing DB records for the run.")
                        (rmt:delete-run run-id)
                        (rmt:delete-old-deleted-test-records))


                    )
                    (if (not (equal?  linkspath "/does/not/exist/I"))
	               (begin 
                         (debug:print 1 *default-log-port* "Recursively removing links dir " linkspath)
                         (runs:recursive-delete-with-error-msg linkspath)))

                   (for-each (lambda(runpath)
                       (debug:print 1 *default-log-port* "Recursively removing runs dir " runpath)
                       (runs:recursive-delete-with-error-msg runpath)
                     )
                     runpaths
                   )
		       )))))
	 ))
     runs)

    ;; special case - archive get
    (if (equal? (args:get-arg "-archive") "get")
	(archive:bup-get-data "get" #f #f test-records rp-mutex bup-mutex))
    )
  #t
  )

(define (runs:remove-test-directory test mode) ;; remove-data-only)
  (let* ((run-dir       (db:test-get-rundir test))    ;; run dir is from the link tree
	 (real-dir      (if (common:file-exists? run-dir)
			    ;; (resolve-pathname run-dir)
			    (common:nice-path run-dir)
			    #f))

      ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
      ((remove-all)      (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
      ((archive-remove)  (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
    (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
    (if (and real-dir 
	     (> (string-length real-dir) 5)
	     (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
	(let* ((realpath (resolve-pathname run-dir)))
	  (debug:print-info 1 *default-log-port* "Recursively removing " realpath)
	  (if (common:file-exists? realpath)
	      (runs:safe-delete-test-dir realpath)
	      (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable")))
	(if real-dir 
	    (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
	    (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
    (if (symbolic-link? run-dir)
	(begin
	  (debug:print-info 1 *default-log-port* "Removing symlink " run-dir)
	  (handle-exceptions

;;======================================================================
;; Routines for manipulating runs
;;======================================================================

;; Since many calls to a run require pretty much the same setup 
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
  (let ((runname (common:args-get-runname))
	(target  (common:args-get-target)))
    (cond
     ((not target)
      (debug:print-error 0 *default-log-port* "Missing required parameter for " switchname ", you must specify the target with -target")
      (exit 3))
     ((not runname)
      (debug:print-error 0 *default-log-port* "Missing required parameter for " switchname ", you must specify the run name with -runname runname")

	    (sqlite3:execute 
	     db 
	     (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) "
		   "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;")
	     (db:test-get-id testdat))))
	 ))
     prev-tests)))

(define doc-template 
  '(*TOP*
    (*PI* xml "version='1.0'")
    (testsuite)))

(define (runs:update-junit-test-reporter-xml run-id)
  (let*	(
	 (junit-test-reporter	(configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
	 (junit-test-report-dir  (configf:lookup *configdat* "runs" "junit-test-report-dir"))
	 (xml-dir		(if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
				    (if junit-test-report-dir
					junit-test-report-dir
					(conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
				    #f))
	 (xml-ts-name		(if xml-dir
				    (conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME"))
				    #f))
         (keyname               (if xml-ts-name (common:get-signature xml-ts-name) #f))
	 (xml-path		(if xml-dir
				    (conc xml-dir "/" keyname ".xml")
				    #f))

	 (test-data		(if xml-dir
				    (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
							   #f #f ;; offset limit
							   #f ;; not-in
							   #f ;; sort-by
							   #f ;; sort-order
							   #f ;; get full data (not 'shortlist)
							   0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
							   #f)
				    '()))
	 (tests-count		(if xml-dir (length test-data) #f)))
    (if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
	(begin
					;((sxml-modify! `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count)))) doc)

	  (let loop	((test		(car test-data))
			 (tail		(cdr test-data))
			 (doc		doc-template)
			 (fail-cnt	0)
			 (error-cnt	0))
	    (let*	((test-name	(vector-ref test 2))
			 (test-itempath	(vector-ref test 11))
			 (tc-name	(conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) "")))
			 (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 "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))
						((member test-status (list "SKIP"))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc))
						(else 
							(debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status))
							((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc))))
			(new-error-cnt	(if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
						(+ error-cnt 1) 
						error-cnt))
			(new-fail-cnt	(if (member test-status (list "FAIL" "CHECK"))
						(+ fail-cnt 1)
						  fail-cnt)))
 	      (if (null? tail)
		    (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc)))
		    (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt)
		    (handle-exceptions
		     exn
		     (let*	((msg	((condition-property-accessor 'exn 'message) exn)))
		       (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg)))
		     		   
		     (if (not (file-exists? xml-dir)) 
			 (create-directory xml-dir #t))
                     (if (not (rmt:no-sync-get/default keyname #f)) 
                       (begin
			 (rmt:no-sync-set  keyname "on")
			 (debug:print 0 *default-log-port* "creating xml at " xml-path)
		         (with-output-to-file xml-path
		         (lambda ()
			   (print (sxml-serializer#serialize-sxml final-doc  ns-prefixes: (list (cons 'gnm "http://foo"))))))
                           (rmt:no-sync-del! keyname))
                          (debug:print 0 *default-log-port*  "Could not get the lock. Skip writing the xml file."))))
		  (loop (car tail) (cdr tail) new-doc new-fail-cnt new-error-cnt))))))))
	 
     
;; clean cache files
(define (runs:clean-cache target runname toppath)
  (if target
      (if runname
	  (let* ((linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree")))

			   (if (eq? time-a time-b)
			       (< id-a id-b)
			       ;; (string<? (conc (vector-ref a 2))
			       ;;	    (conc (vector-ref b 2)))
			       #f))
		       (string<? (conc time-a)(conc time-b)))))))))


;; Save test state and status in to a file .final-status in the test directory
;;
(define (tests:save-final-status run-id test-id)
  (let* ((test-dat  (rmt:get-test-info-by-id run-id test-id))
	 (out-dir   (db:test-get-rundir test-dat))
	 (status-file  (conc out-dir "/.final-status"))
   )
    ;; first verify we are able to write the output file
    (if (not (file-write-access? out-dir))
	    (debug:print 0 *default-log-port* "ERROR: cannot write .final-status to " out-dir)
	    (let* 
         ((outp      (open-output-file status-file))
	       (status    (db:test-get-status   test-dat))
         (state     (db:test-get-state    test-dat)))
        (fprintf outp "~S\n" state) 
        (fprintf outp "~S\n" status) 
        (close-output-port outp)))))


;; summarize test in to a file test-summary.html in the test directory
;;
(define (tests:summarize-test run-id test-id)
  (let* ((test-dat  (rmt:get-test-info-by-id run-id test-id))
	 (out-dir   (db:test-get-rundir test-dat))
	 (out-file  (conc out-dir "/test-summary.html")))

	       (oup       (open-output-file out-file))
	       (status    (db:test-get-status   test-dat))
	       (color     (common:get-color-from-status status))
	       (logf      (db:test-get-final_logf test-dat))
	       (steps-dat (tests:get-compressed-steps run-id test-id)))
	  ;; (dcommon:get-compressed-steps #f 1 30045)
	  ;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log"))
	
	  (s:output-new
	   oup
	   (s:html
	    (s:title "Summary for " full-name)
	    (s:body 
	     (s:h2 "Summary for " full-name)
	     (s:table 'cellspacing "0" 'border "1"

  unset ${var}
done
cd $1
shift
export PATH="$1:$PATH"
shift 

exec "$@"