Megatest

# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
# rm <files>.o ; make install CSCOPTS='-profile' ; ... ;  chicken-profile | less

PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
   ods.scm runconfig.scm server.scm configf.scm \
   db.scm keys.scm margs.scm megatest-version.scm \
   process.scm runs.scm tasks.scm tests.scm genexample.scm \
   http-transport.scm filedb.scm tdb.scm \
   client.scm daemon.scm mt.scm \
   ezsteps.scm lock-queue.scm sdb.scm \
   rmt.scm api.scm \
   rmt.scm api.scm subrun.scm \
   portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm

# module source files
MSRCFILES = ftail.scm

# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \

	rpc-transport.o \
	runconfig.o \
	runs.o \
	server.o \
	tasks.o \
	tdb.o \
	tests.o \
	subrun.o \


tcmt : $(TCMTOBJS) tcmt.scm
	csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt

# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS

(define api:read-only-queries
  '(get-key-val-pairs
    get-var
    get-keys
    get-key-vals
    test-toplevel-num-items
    get-test-info-by-id
    get-steps-info-by-id
    get-data-info-by-id
    test-get-rundir-from-test-id
    get-count-tests-running-for-testname
    get-count-tests-running
    get-count-tests-running-in-jobgroup
    get-previous-test-run-record
    get-matching-previous-test-run-records
    test-get-logfile-info

    read-test-data
    read-test-data*
    login
    tasks-get-last
    testmeta-get-record
    have-incompletes?
    synchash-get
    get-changed-record-ids 
    ))

(define api:write-queries
  '(
    get-keys-write ;; dummy "write" query to force server start

    ;; SERVERS

(define (pgdb:get-test-data-id dbh test-id category variable)
  (dbi:get-one
    dbh
    "SELECT id FROM test_data WHERE test_id=? AND category=? and variable = ? ;"
    test-id category variable))

(define (pgdb:insert-test-data dbh test-id category variable value expected tol units comment status type)
 ; (print "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type)
 ;      VALUES (?,?,?,?,?,?,?,?,?,?) " test-id " " category " " variable " " value " "  expected " "  tol " "  units " " comment  " " status  " " type)
  (if (not (string? units))
      (set! units "" ))
  (if (not (string? variable))
      (set! variable "" ))
  (if (not (real? value))
      (set! value 0 ))
  (if (not (real? expected))
      (set! expected 0  ))
(if (not (real? tol))
      (set! tol 0  ))

  (dbi:exec
   dbh
   "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type)
       VALUES (?,?,?,?,?,?,?,?,?,?);"
   test-id category variable value expected tol units comment status type))

(define (pgdb:update-test-data dbh data-id test-id  category variable value expected tol units comment status type)

(use srfi-1 data-structures posix regex-case (prefix base64 base64:)
     format dot-locking csv-xml z3 ;; sql-de-lite
     hostinfo md5 message-digest typed-records directory-utils stack
     matchable regex posix (srfi 18) extras ;; tcp 
     (prefix nanomsg nmsg:)
     (prefix sqlite3 sqlite3:)
     pkts)
     pkts
     )

(declare (unit common))

(include "common_records.scm")


;; (require-library margs)
;; (include "margs.scm")

;; (define old-exit exit)
;; 
;; (define (exit . code)

  0)

(define (std-signal-handler signum)
  ;; (signal-mask! signum)
  (set! *time-to-exit* #t)
  ;;(debug:print-info 13 *default-log-port* "got signal "signum)
  (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly")
  (debug:print-error 0 *default-log-port* "Received signal " signum " aaa exiting promptly")
  ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
  (exit))

(define (special-signal-handler signum)
  ;; (signal-mask! signum)
  (set! *time-to-exit* #t)
  ;;(debug:print-info 13 *default-log-port* "got signal "signum)
  (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting!!")
  ;;TODO send email to notify admin contact listed in the config that the lisner got killed
  ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
  (exit))


(set-signal-handler! signal/int  std-signal-handler)  ;; ^C
(set-signal-handler! signal/term std-signal-handler)

;; (set-signal-handler! signal/stop std-signal-handler)  ;; ^Z NO, do NOT handle ^Z!

;;======================================================================
;; M I S C   U T I L S
;;======================================================================

;; convert stuff to a number if possible

				       (string-search whitesp key)
				       (string-search ":" key)) ;; internal only values to be skipped.
				   "# export "
				   "export ")
			       key "=" delim (mungeval val) delim)))
                    envvars)))))


(define (common:get-param-mapping #!key (flavor #f))
  "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches"
  (let ((default '(("tag-expr"  . "-tagexpr")
                   ("mode-patt" . "-modepatt")
                   ("run-name"  . "-runname")
                   ("contour"   . "-contour")
                   ("mode-patt" . "-mode-patt")
                   ("target"    . "-target")
                   ("test-patt" . "-testpatt")
                   ("msg"       . "-m")
                   ("log"       . "-log")
                   ("start-dir" . "-start-dir")
                   ("new"       . "-set-state-status"))))
    (if (eq? flavor 'switch-symbol)
        (map (lambda (x)
               (cons (string->symbol (conc "-" (car x))) (cdr x)))
             default)
        default)))

;; set some env vars from an alist, return an alist with original values
;; (("VAR" "value") ...)
;; a value of #f means "unset this var"
;;
(define (alist->env-vars lst)
  (if (list? lst)
      (let ((res '()))
	(for-each (lambda (p)
		    (let* ((var (car  p))
			   (val (cadr p))
			   (prv (get-environment-variable var)))
		      (set! res (cons (list var prv) res))
		      (if val 
			  (safe-setenv var (->string val))
			  (unsetenv var))))
		  lst)
	res)
      '()))


;; clear vars matching pattern, run proc, set vars back
;; if proc is a string run that string as a command with
;; system.
;;
(define (common:without-vars proc . var-patts)
  (let ((vars (make-hash-table)))

     ((string? proc)(system proc))
     (proc          (proc)))
    (hash-table-for-each
     vars
     (lambda (var val)
       (setenv var val)))
    vars))


(define (common:run-a-command cmd #!key (with-vars #f))
  (let* ((pre-cmd  (dtests:get-pre-command))
         (post-cmd (dtests:get-post-command))
         (fullcmd  (if (or pre-cmd post-cmd)
                       (conc pre-cmd cmd post-cmd)
                       (conc "viewscreen " cmd))))

		      (alist->pkt pktalist common:pkts-spec)))
	  (hash-table-set! *pkts-info* 'last-parent uuid)
	  (let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f)
			     (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
				    (pktsdir   (car pktsdirs))) ;; assume it is there
			       (hash-table-set! *pkts-info* 'pkts-dir pktsdir)
			       pktsdir))))
            (handle-exceptions
             exn
             (debug:print-info 0 "failed to write out packet to " pktsdir) ;; don't care if this failed for now but MUST FIX - BUG!!
	    (if (not (file-exists? pktsdir))
		(create-directory pktsdir #t))
	    (with-output-to-file
		(conc pktsdir "/" uuid ".pkt")
	      (lambda ()
		(print pkt))))))))
             (if (not (file-exists? pktsdir))
                 (create-directory pktsdir #t))
             (with-output-to-file
                 (conc pktsdir "/" uuid ".pkt")
               (lambda ()
                 (print pkt)))))))))
	
(define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f))
  (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
	 (pktsdir  (if pktsdirs (car pktsdirs) #f))
	 (toppath  (or (configf:lookup mtconf "scratchdat" "toppath")
		       toppath-in))
	 (pdbpath  (or (configf:lookup mtconf "setup"  "pdbpath") pktsdir)))

                     ((string? new-val)
                      (setenv env-var new-val)))
                    restore-thunk))
                delta-env-alist))))
    (let ((rv (thunk)))
      (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
      rv)))

(define (common:send-thunk-to-background-thread thunk #!key (name #f))
  ;;(BB> "launched thread " name)
  (if name
      (thread-start! (make-thread thunk name))
      (thread-start! (make-thread thunk))))

(define (submegatest-panel dbstruct keydat testdat runname testconfig)
  (let* ((test-run-dir      (db:test-get-rundir testdat))
	 (subrun-tconf-file (conc test-run-dir "/testconfig.subrun"))
	 (subrun-tconf      (if (file-exists? subrun-tconf-file)
				(configf:read-alist subrun-tconf-file)
				(make-hash-table)))
	 (subarea           (or (configf:lookup testconfig "setup" "submegatest")
				(configf:lookup subrun-tconf "subrun" "runarea")))
				(configf:lookup subrun-tconf "subrun" "run-area")))
	 (area-exists (and subarea (common:file-exists? subarea))))
    ;; (debug:print-info 0 *default-log-port* "Megatest subarea=" subarea ", area-exists=" area-exists)
    (if subarea
	(iup:frame 
	 #:title "Megatest Run Info" ; #:expand "YES"
	 (iup:button
	  "Launch Dashboard"

</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br>
Last updated 2016-12-12 13:03:08 PST
Last updated 2017-12-14 13:23:12 PST
</div>
</div>
</body>
</html>

<div class="paragraph"><p>In the testconfig:</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>[subrun]

# Required: wait for the run or just launch it
#           if no then the run will be an automatic PASS irrespective of the actual result
runwait yes|no
run-wait yes|no

# Optional: where to execute the run. Default is the current runarea
runarea /some/path/to/megatest/area
run-area /some/path/to/megatest/area

# Optional: method to use to determine pass/fail status of the run
#   auto (default) - roll up the net state/status of the sub-run
#   logpro         - use the provided logpro rules, happens automatically if there is a logpro section
# passfail auto|logpro
# Example of logpro:
passfail logpro

# Optional:
logpro ;; if this section exists then logpro is used to determine pass/fail
  (expect:required in "LogFileBody" &gt;= 1 "At least one pass" #/PASS/)
  (expect:fail     in "LogFileBody"  = 0 "No FAILs allowed"  #/FAIL/)

# Optional: target translator, default is to use the parent target
target #{shell somescript.sh}

# Optional: runname translator/generator, default is to use the parent runname
runname #{somescript.sh}
run-name #{somescript.sh}

# Optional: testpatt spec, default is to first look for TESTPATT spec from runconfigs unless there is a contour spec
testpatt %/item1,test2
test-patt %/item1,test2

# Optional: contour spec, use the named contour from the megatest.config contour spec
contour contourname ### NOTE: Not implemented yet! Let us know if you need this feature.

# Optional: mode-patt, use this spec for testpatt from runconfigs
mode-patt TESTPATT

# Optional: tag-expr, use this tag-expr to select tests
tag-expr quick

# Optional: (not yet implemented), propagate these actions from the parent
# Optional: (not yet implemented, remove-runs is always propagated at this time), propagate these actions from the parent
#           test
#   Note// default is % for all
propagate remove-runs archive ...</pre>
</div></div>
</div>
</div>
<div class="sect1">

</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br>
Last updated 2017-07-17 14:05:11 PDT
Last updated 2017-12-14 13:23:12 PST
</div>
</div>
</body>
</html>

In the testconfig:
---------------
[subrun]

# Required: wait for the run or just launch it
#           if no then the run will be an automatic PASS irrespective of the actual result
runwait yes|no
run-wait yes|no

# Optional: where to execute the run. Default is the current runarea
runarea /some/path/to/megatest/area
run-area /some/path/to/megatest/area

# Optional: method to use to determine pass/fail status of the run
#   auto (default) - roll up the net state/status of the sub-run
#   logpro         - use the provided logpro rules, happens automatically if there is a logpro section
# passfail auto|logpro
# Example of logpro:
passfail logpro

# Optional: 
logpro ;; if this section exists then logpro is used to determine pass/fail
  (expect:required in "LogFileBody" >= 1 "At least one pass" #/PASS/)
  (expect:fail     in "LogFileBody"  = 0 "No FAILs allowed"  #/FAIL/)

# Optional: target translator, default is to use the parent target
target #{shell somescript.sh}

# Optional: runname translator/generator, default is to use the parent runname
runname #{somescript.sh}
run-name #{somescript.sh}

# Optional: testpatt spec, default is to first look for TESTPATT spec from runconfigs unless there is a contour spec
testpatt %/item1,test2
test-patt %/item1,test2

# Optional: contour spec, use the named contour from the megatest.config contour spec
contour contourname ### NOTE: Not implemented yet! Let us know if you need this feature.

# Optional: mode-patt, use this spec for testpatt from runconfigs
mode-patt TESTPATT

# Optional: tag-expr, use this tag-expr to select tests
tag-expr quick

# Optional: (not yet implemented), propagate these actions from the parent
# Optional: (not yet implemented, remove-runs is always propagated at this time), propagate these actions from the parent
#           test
#   Note// default is % for all
propagate remove-runs archive ...

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

Programming API

(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv)
(use typed-records pathname-expand matchable)

(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))

(declare (unit launch))
(declare (uses subrun))
(declare (uses common))
(declare (uses configf))
(declare (uses db))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")

	       (begin
		 (thread-sleep! 2)
		 (loop (+ i 1)))
	       )))))
  ;; then, if runscript ran ok (or did not get called)
  ;; do all the ezsteps (if any)
  (if (or ezsteps subrun)
      (let* ((test-run-dir (tests:get-test-path-from-environment))
      (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
             (testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
	      ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
	      ;;       ezstep names need a full re-eval here.
	      (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
	     (ezstepslst (if (hash-table? testconfig)
			     (hash-table-ref/default testconfig "ezsteps" '())
			     #f)))
	(if testconfig

	;; 1. get section [runarun]
	;; 2. unset MT_* vars
	;; 3. fix target
	;; 4. fix runname
	;; 5. fix testpatt or calculate it from contour
	;; 6. launch the run
	;; 7. roll up the run result and or roll up the logpro processed result
	(if (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested
	(when (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested
	    (let* ((runarea   (let ((ra (configf:lookup testconfig "subrun" "runarea")))
				(if ra      ;; when runarea is not set we default to *toppath*. However 
				    ra      ;; we need to force the setting in the testconfig so it will
				    (begin  ;; be preserved in the testconfig.subrun file
				      (configf:set-section-var testconfig "subrun" "runarea" *toppath*)
				      *toppath*))))
		   (passfail  (configf:lookup testconfig "subrun" "passfail"))
		   (target    (or (configf:lookup testconfig "subrun" "target") (get-environment-variable "MT_TARGET")))
		   (runname   (or (configf:lookup testconfig "subrun" "runname")(get-environment-variable "MT_RUNNAME")))
		   (contour   (configf:lookup testconfig "subrun" "contour"))
            (subrun:initialize-toprun-test testconfig test-run-dir)
		   (testpatt  (configf:lookup testconfig "subrun" "testpatt"))
		   (mode-patt (configf:lookup testconfig "subrun" "mode-patt"))
		   (tag-expr  (configf:lookup testconfig "subrun" "tag-expr"))
		   (run-wait  (configf:lookup testconfig "subrun" "runwait"))
		   (logpro    (configf:lookup testconfig "subrun" "logpro"))
		   (compact-stem (string-substitute "[/*]" "_" (conc target "-" runname "-" (or testpatt mode-patt tag-expr))))
		   (log-file (conc compact-stem ".log"))
		   (mt-cmd    (conc "megatest -run -target " target
				    " -runname " runname
				    (conc " -start-dir " runarea) ;; (if runarea runarea *toppath*))
				    (if testpatt  (conc " -testpatt " testpatt)  "")
				    (if mode-patt (conc " -modepatt " mode-patt) "")
				    (if tag-expr  (conc " -tag-expr"  tag-expr)  "")
				    (if (equal? run-wait "yes") " -run-wait " "")
				    " -log " log-file)))
	      ;; change directory to runarea, create it if needed, we do NOT create the directory 
	;; (if runarea
	;;     (if (directory-exists? runarea)
	;;         (change-directory runarea)
	;;         (begin
	;;   	(debug:print 0 *default-log-port* "ERROR: for sub-megatest run the runarea \"" runarea "\" does not exist! EXITING.")
	;;   	(exit 1))))
	      ;; (let ((subrun (conc *toppath* "/subrun") #t))
	      ;; 	 (create-directory subrun)
	      ;; 	 (change-directory subrun)))
	      
	    (let* ((mt-cmd (subrun:launch-cmd test-run-dir)))
	      ;; by this point we are in the right place to run the subrun and we have a Megatest command to run
	      ;; (filter (lambda (x)(string-match "MT_.*" (car x))) (get-environment-variables))
	      ;; (common:without-vars mt-cmd "^MT_.*")
              (debug:print-info 0 *default-log-port* "Subrun command is \"" mt-cmd "\"")
              (set! ezsteps #t) ;; set the needed flag
	      (set! ezstepslst (append (or ezstepslst '())
                                       (list (list "subrun" (conc "{subrun=true} " mt-cmd)))))
	      (set! ezstepslst
                    (append (or ezstepslst '())
                            (list (list "subrun" (conc "{subrun=true} " mt-cmd)))))))
	      (configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun
              (if runarea (configf:set-section-var testconfig "setup" "submegatest" runarea))
              (configf:write-alist testconfig "testconfig.subrun")
	      ))

	;; process the ezsteps
	(if ezsteps
	    (begin
	      (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
	      ;; if ezsteps was defined then we are sure to have at least one step but check anyway
	      (if (not (> (length ezstepslst) 0))

                            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
  -generate-html          : create a simple html tree for browsing your runs
  -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>

  		

			"-lock"
			"-unlock"
			"-list-servers"
			"-kill-servers"
                        "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
			"-one-pass"       ;;
			"-local"         ;; run some commands using local db access
                        "-generate-html"
      "-generate-html"
      "-generate-html-structure" 
			"-list-run-time"
                        "-list-test-time"
			;; misc queries
			"-list-disks"
			"-list-targets"
			"-list-db-targets"
			"-show-runconfig"

     
(if (args:get-arg "-generate-html")
    (let* ((toppath (launch:setup)))
      (if (tests:create-html-tree #f)
          (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page#.html")
          (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
      (set! *didsomething* #t)))

(if (args:get-arg "-generate-html-structure")
    (let* ((toppath (launch:setup)))
      ;(if (tests:create-html-tree #f)
 				(if (tests:create-html-summary #f)
          (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
          (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
      (set! *didsomething* #t)))
;;======================================================================
;; Exit and clean up
;;======================================================================

(if (not *didsomething*)
    (debug:print 0 *default-log-port* help)
    (set! *time-to-exit* #t)

-- CREATE TABLE IF NOT EXISTS keys (
--        id SERIAL PRIMARY KEY,
--        fieldname TEXT,
--        fieldtype TEXT,
--        CONSTRAINT keyconstraint UNIQUE (fieldname));

DROP VIEW IF EXISTS area_tag_view;
DROP TABLE IF EXISTS areas;
DROP TABLE IF EXISTS ttype;
DROP TABLE IF EXISTS runs;
DROP TABLE IF EXISTS run_stats;
DROP TABLE IF EXISTS test_meta;
DROP TABLE IF EXISTS tasks_queue;
DROP TABLE IF EXISTS archive_disks;

DROP TABLE IF EXISTS archives;
DROP TABLE IF EXISTS session_vars;
DROP TABLE IF EXISTS sessions;
DROP TABLE IF EXISTS tags;
DROP TABLE IF EXISTS users; 
DROP TABLE IF EXISTS webviews;
DROP TABLE IF EXISTS area_tags;

DROP TABLE IF EXISTS users_webviews;



CREATE TABLE IF NOT EXISTS session_vars (
       id SERIAL PRIMARY KEY,
       session_id INTEGER,
       page TEXT,
       key TEXT,
       value TEXT);

CREATE TABLE IF NOT EXISTS area_tags (
       id SERIAL PRIMARY KEY,
       tag_id   INTEGER DEFAULT 0,
       area_id  INTEGER DEFAULT 0,
       CONSTRAINT areatagconstraint UNIQUE (tag_id, area_id));

CREATE VIEW area_tag_view as 
select a.id as aid, t.id as tid,area_name,tag_name from areas as a inner join area_tags as at on at.area_id = a.id
inner join tags as t on t.id = at.tag_id  ;

INSERT INTO areas (id,area_name,area_path) VALUES (0,'local','.');

CREATE TABLE IF NOT EXISTS ttype (
       id SERIAL PRIMARY KEY,
       target_spec TEXT DEFAULT '');
       
CREATE TABLE IF NOT EXISTS runs (

       status       TEXT DEFAULT 'n/a',
       archive_type TEXT DEFAULT 'bup',
       du           INTEGER,
       archive_path TEXT);
 
CREATE TABLE IF NOT EXISTS users(
   id SERIAL  PRIMARY KEY   ,
   usename           TEXT    NOT NULL,
   username           TEXT    NOT NULL,
   fullname          TEXT    NOT NULL, 
   email             TEXT    NOT NULL, 
   default_view      TEXT    default '',
   deleted           INTEGER     default 0
);
 
CREATE TABLE IF NOT EXISTS webviews(
   id SERIAL  PRIMARY KEY   ,
   owner_id          INTEGER NOT NULL,
   name              TEXT    NOT NULL, 
   ttype_id          INTEGER DEFAULT 0,
   view_specifics    TEXT   ,
   col               TEXT    NOT NULL,
   row               TEXT    NOT NULL,
   public            INTEGER DEFAULT 0,
   deleted           INTEGER     default 0
);



CREATE TABLE IF NOT EXISTS users_webviews(
 id      SERIAL  PRIMARY KEY   ,
 user_id   INTEGER NOT NULL,
 webview_id  INTEGER NOT NULL,
 deleted     INTEGER default 0,
 searchpattern TEXT Default ''
);


-- TRUNCATE archive_blocks, archive_allocations, extradat, metadat,
-- access_log, tests, test_steps, test_data, test_rundat, archives, runs,
-- run_stats, test_meta, tasks_queue, archive_disks;

;;======================================================================
;;  U T I L S
;;======================================================================

;; given a mtutil param, return the old megatest equivalent
;;
(define (param-translate param)
  (or (alist-ref (string->symbol param)
(define (megatest-param->mtutil-param param)
  (let* ((mapping-alist (common:get-param-mapping flavor: 'switch-symbol)))
    (alist-ref (string->symbol param) mapping-alist eq? param)
		 '((-tag-expr  . "-tagexpr")
		   (-mode-patt . "-modepatt")
		   (-run-name  . "-runname")
		   (-test-patt . "-testpatt")
		   (-msg       . "-m")
		   (-new       . "-set-state-status")))
      param))
    param))

(define (val->alist val)
  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
    (if val-list
	(map (lambda (x)
	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
		 (case (length f)

		    runkeydats)))
	       (let ((res (configf:get-section torun contour))) ;; each contour / target
		 ;; (print "res=" res)
		 res))))
	  (hash-table-keys torun)))))))

(define (pkt->cmdline pkta)
  (let* ((param-mapping-alist (common:get-param-mapping flavor: 'switch-symbol))
  (let* ((action (or (lookup-action-by-key (alist-ref 'A pkta)) "noaction"))
	 (action-param (case (string->symbol action)
			 ((-set-state-status) (conc (alist-ref 'l pkta) " "))
			 (else ""))))
         (action        (or (lookup-action-by-key (alist-ref 'A pkta)) "noaction"))
	 (action-param  (case (string->symbol action)
                          ((-set-state-status) (conc (alist-ref 'l pkta) " "))
                          (else ""))))
    (fold (lambda (a res)
	    (let* ((key (car a)) ;; get the key name
		   (val (cdr a))
		   (par (or (lookup-param-by-key key)  ;; need to check also if it is a switch
			    (lookup-param-by-key key inlst: *switch-keys*))))
	      ;; (print "key: " key " val: " val " par: " par)
	      (if par
		  (conc res " " (param-translate par) " " val)
		  (conc res " " (alist-ref (string->symbol par) param-mapping-alist eq? par) " " val)
		  (if (alist-ref key *additional-cards*) ;; these cards do not translate to parameters or switches
		      res
		      (begin
			(print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"")
			res)))))
	  (conc "megatest " (if (not (member action '("sync")))
				(conc action " " action-param)

                 (begin
                   (if (not (is-port-in-use portnum))  
                       (let* ((rep       (start-nn-server portnum))
                           (mtconfdat (simple-setup (args:get-arg "-start-dir")))
                           (mtconf    (car mtconfdat))
                           (script    (configf:lookup mtconf "listener" "script")))
                           (print "Listening on port " portnum " for messages")
														(set-signal-handler! signal/int  special-signal-handler)
														(set-signal-handler! signal/term special-signal-handler)

                           (let loop ((instr (nn-recv rep)))
                            (let loop ((instr (nn-recv rep)))
                               (print "received " instr ", running \"" script " " instr "\"")
                               (system (conc script " '" instr "'"))
                               (nn-send rep "ok")
                               (loop (nn-recv rep))))
                     (print "ERROR: Port " portnum " already in use. Try another port")))))))
      
      )) ;; the end

		      (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f)
		      ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug.
		      (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
		      (list (if (null? tal)(car newtal)(car tal))
			    tal
			    reg
			    reruns)))))
	      ;; ELSE: can't drop this - maybe running? Just keep trying
                ;; ELSE: can't drop this - maybe running? Just keep trying

                ;;(if (not (or (not (null? reg))(not (null? tal)))) ;; old experiment
                (let ((runable-tests (runs:runable-tests prereqs-not-met))) ;; SUSPICIOUS: Should look at more than just prereqs-not-met?
                  (if (null? runable-tests)
                      #f   ;; I think we are truly done here
                      (runs:loop-values newtal reg reglen regfull reruns)))
                ;;) ;;from old experiment
            ) ;; end if (or (not (null? reg))(not (null? tal)))
                ) ;; end if (or (not (null? reg))(not (null? tal)))
            ))))))

;; scan a list of tests looking to see if any are potentially runnable
;;
(define (runs:runable-tests tests)
  (filter (lambda (t)
	    (if (not (vector? t))

   inc-results: (make-hash-table)
   inc-results-last-update: 0
   inc-results-fmt: "~12a~12a~20a~12a~40a\n" ;; state status time duration test-name item-path
   run-info: #f
   runname: #f
   target: #f
   )
)
  )

(define (runs:incremental-print-results run-id)
  (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)

	;; 	 (not (or (and *runremote*
	;; 		       (remote-server-url *runremote*)
	;; 		       (server:ping (remote-server-url *runremote*)))
	;; 		  (server:check-if-running *toppath*))))
	;;     (server:kind-run *toppath*))
	
	(if (> num-running 0)
	  (set! last-time-some-running (current-seconds)))
            (set! last-time-some-running (current-seconds)))

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

	;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard
	;; and it is clear they *should* have run but did not.

	      (if (runs:lownoise (conc "been marked do not run " tfullname) 60)
		  (debug:print-info 0 *default-log-port* "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable"))
	      (if (or (not (null? tal))(not (null? reg)))
		  (loop (runs:queue-next-hed tal reg reglen regfull)
			(runs:queue-next-tal tal reg reglen regfull)
			(runs:queue-next-reg tal reg reglen regfull)
			reruns))))
		  ;; (loop (car tal)(cdr tal) reg reruns))))
        ;; (loop (car tal)(cdr tal) reg reruns))))

	(runs:incremental-print-results run-id)
	(debug:print 4 *default-log-port* "TOP OF LOOP => "
		     "test-name: " test-name
		     "\n  hed:         " hed
		     "\n  tal:         " tal
		     "\n  reg:         " reg

	  (debug:print-info 4 *default-log-port* "OUTER COND: (not items)")
	  (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
		   (not (null? tal)))
	      (loop (car tal)(cdr tal) reg reruns))
	  (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
	  (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
	  (let ((loop-list (runs:process-expanded-tests runsdat testdat)))
	      (if loop-list (apply loop loop-list))))
            (if loop-list (apply loop loop-list))))

	 ;; items processed into a list but not came in as a list been processed
	 ;;
	 ((and (list? items)     ;; thus we know our items are already calculated
	       (not   itemdat))  ;; and not yet expanded into the list of things to be done
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-3")
	  (debug:print-info 4 *default-log-port* "OUTER COND: (and (list? items)(not itemdat))")
	  ;; Must determine if the items list is valid. Discard the test if it is not.
	  (if (and (list? items)
		   (> (length items) 0)
		   (and (list? (car items))
			(> (length (car items)) 0))
		   (debug:debug-mode 1))
	      (debug:print 2 *default-log-port* (map (lambda (row)
				    (conc (string-intersperse
					   (map (lambda (varval)
						  (string-intersperse varval "="))
						row)
					   " ")
					  "\n"))
				  items)))
                                                       (conc (string-intersperse
                                                              (map (lambda (varval)
                                                                     (string-intersperse varval "="))
                                                                   row)
                                                              " ")
                                                             "\n"))
                                                     items)))

          (let* ((items-in-testpatt
                  (filter
                   (lambda (my-itemdat)
                     (tests:match test-patts hed (item-list->path my-itemdat) ))
                   ;; was: (tests:match test-patts hed (item-list->path my-itemdat) required: required-tests))
                   items) ))

                            (let* ((new-test-record (let ((newrec (make-tests:testqueue)))
                                                      (vector-copy! test-record newrec)
                                                      newrec))
                                   (my-item-path (item-list->path my-itemdat))

                                   (newtestname (db:test-make-full-name hed my-item-path)))    ;; test names are unique on testname/item-path
                              (tests:testqueue-set-items!     new-test-record #f)
                            (tests:testqueue-set-itemdat!   new-test-record my-itemdat)
                            (tests:testqueue-set-item_path! new-test-record my-item-path)
                            (hash-table-set! test-records newtestname new-test-record)
                            (set! tal (append tal (list newtestname)))))  ;; since these are itemized create new test names testname/itempath
                              (tests:testqueue-set-itemdat!   new-test-record my-itemdat)
                              (tests:testqueue-set-item_path! new-test-record my-item-path)
                              (hash-table-set! test-records newtestname new-test-record)
                              (set! tal (append tal (list newtestname)))))  ;; since these are itemized create new test names testname/itempath
                          items-in-testpatt)))
                          
            
          
          

	  ;; At this point we have possibly added items to tal but all must be handed off to 
	  ;; INNER COND logic. I think loop without rotating the queue 
	  ;; (loop hed tal reg reruns))
	  ;; (let ((newtal (append tal (list hed))))  ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test
	  ;; (loop (car newtal)(cdr newtal) reg reruns)
	  (if (null? tal)
	      #f
	      (loop (car tal)(cdr tal) reg reruns)))
	    
         
	 ;; if items is a proc then need to run items:get-items-from-config, get the list and loop 
	 ;;    - but only do that if resources exist to kick off the job
	 ;; EXPAND ITEMS
	 ((or (procedure? items)(eq? items 'have-procedure))
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-4")
	  (let ((can-run-more    (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
	    (if (and (list? can-run-more)
		     (car can-run-more))
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps))) ;; itemized test expanded here
		  (if loop-list
		      (apply loop loop-list)
                      (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed)
                      )
                  )
		;; if can't run more just loop with next possible test
		(loop (car newtal)(cdr newtal) reg reruns))))
	    
         
	 ;; this case should not happen, added to help catch any bugs
	 ((and (list? items) itemdat)
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-5")
	  (debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this")
	  (exit 1))
	 ((not (null? reruns))
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-6")

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

			       " " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S")
			       " " (if remove "REMOVE" "")))
		       ((remove-runs)
			(if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"))))
		       ((archive)
			(if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %"))))))
		   actions))))
	    sorted)))
          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 (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)))

	  (exit)))
    (for-each
     (lambda (run)
       (let ((runkey (string-intersperse (map (lambda (k)
						(db:get-value-by-header run header k)) keys) "/"))
	     (dirs-to-remove (make-hash-table))
	     (proc-get-tests (lambda (run-id)
			      (mt:get-tests-for-run run-id
						    testpatt states statuses
						    not-in:  #f
						    sort-by: (case action
							       ((remove-runs) 'rundir)
							       (else          'event_time))))))
                               (mt:get-tests-for-run run-id
                                                     testpatt states statuses
                                                     not-in:  #f
                                                     sort-by: (case action
                                                                ((remove-runs) 'rundir)
                                                                (else          'event_time))))))
	 (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")

									 (dirb ;; (rmt:sdb-qry 'getstr 
									  (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b))))
								     (if (and (string? dira)(string? dirb))
									 (> (string-length dira)(string-length dirb))
									 #f))))))
		       (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests
		       (test-retry-time  (make-hash-table))
                       (backgrounded-remove-status     (make-hash-table))
                       (backgrounded-remove-last-visit (make-hash-table))
                       (backgrounded-remove-result     (make-hash-table))
		       (allow-run-time   10)) ;; seconds to allow for killing tests before just brutally killing 'em
		   (let loop ((test (car sorted-tests))
			      (tal  (cdr sorted-tests)))
		     (let* ((test-id       (db:test-get-id test))
			    (new-test-dat  (rmt:get-test-info-by-id run-id test-id)))
		       (if (not new-test-dat)
			   (begin
			     (debug:print-error 0 *default-log-port* "We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
			     (if (not (null? tal))
				 (loop (car tal)(cdr tal))))
			   (let* ((item-path     (db:test-get-item-path new-test-dat))
				  (test-name     (db:test-get-testname new-test-dat))
				  (run-dir       ;;(filedb:get-path *fdb*
				   ;; (rmt:sdb-qry 'getid 
				   (db:test-get-rundir new-test-dat)) ;; )    ;; run dir is from the link tree
                                  (has-subrun    (and (subrun:subrun-test-initialized? run-dir)
                                                      (not (subrun:subrun-removed? run-dir))))
				  (test-state    (db:test-get-state new-test-dat))
				  (test-fulln    (db:test-get-fullname new-test-dat))
				  (uname         (db:test-get-uname    new-test-dat))
				  (toplevel-with-children (and (db:test-get-is-toplevel test)
							       (> (rmt:test-toplevel-num-items run-id test-name) 0))))
			     (case action
			       ((remove-runs)
				;; if the test is a toplevel-with-children issue an error and do not remove
				(cond
				(if toplevel-with-children
                                 (toplevel-with-children
				    (begin
				      (debug:print 0 *default-log-port* "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests")
				      (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1))
				      (if (> (hash-table-ref toplevel-retries test-fulln) 3)
					  (if (not (null? tal))
					      (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries
					  (let ((newtal (append tal (list test))))
					    (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue
				    (begin
				      (debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state)
				      (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
					  (begin
					    (if (not (hash-table-ref/default test-retry-time test-fulln #f))
						(begin
						  ;; want to set to REMOVING BUT CANNOT do it here?
						  (hash-table-set! test-retry-time test-fulln (current-seconds))))
					    (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time)
						;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first
						;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give
						;; up and blow it away.
						(begin
						  (debug:print 0 *default-log-port* "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing")
					    (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f)
						  (thread-sleep! 1))
						(begin
					    (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
					    (runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
					    (if (not (null? tal))
						(loop (car tal)(cdr tal)))))))
                                  (debug:print 0 *default-log-port* "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests")
                                  (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1))
                                  (if (> (hash-table-ref toplevel-retries test-fulln) 3)
                                      (if (not (null? tal))
                                          (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries
                                      (let ((newtal (append tal (list test))))
                                        (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue
                                 (has-subrun
                                  ;; 
                                  (let ((last-visit (hash-table-ref/default backgrounded-remove-last-visit test-fulln 0))
                                        (now        (current-seconds))
                                        (rem-status (hash-table-ref/default backgrounded-remove-status test-fulln 'not-started)))
                                    (case rem-status
                                      ((not-started)
                                       (debug:print 0 *default-log-port* "WARNING: postponing removal of " test-fulln " with run-id " run-id " as it has a subrun")
                                       (hash-table-set! backgrounded-remove-status test-fulln 'started)
                                       (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds))
                                       (common:send-thunk-to-background-thread
                                        (lambda ()
                                          (let* ((subrun-remove-succeeded
                                                  (subrun:remove-subrun run-dir keep-records)))
                                            (hash-table-set! backgrounded-remove-result test-fulln subrun-remove-succeeded)
                                            (hash-table-set! backgrounded-remove-status test-fulln 'done)))
                                        name: (conc "remove-subrun:"test-fulln))
                                       
                                       ;; send to back of line, loop
                                       (let ((newtal (append tal (list test))))
                                        (loop (car newtal)(cdr newtal)))
                                       )
                                      ((started)
                                       ;; if last visit was within last second, sleep 1 second
                                       (if (< (- now last-visit) 1.0)
                                           (thread-sleep! 1.0))
                                       (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds))
                                       ;; send to back of line, loop
                                       (let ((newtal (append tal (list test))))
                                        (loop (car newtal)(cdr newtal)))
                                       )
                                      ((done)
                                       ;; drop this one; if remaining, loop, else finish
                                       (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds))
                                       (let ((subrun-remove-succeeded (hash-table-ref/default backgrounded-remove-result test-fulln 'exception)))
                                         (cond
                                          ((eq? subrun-remove-succeeded 'exception)
                                           (let* ((logfile (subrun:get-log-path run-dir "remove")))
                                             (debug:print 0 *default-log-port* "ERROR: removing subrun of of " test-fulln " with run-id " run-id " ; see logfile @ "logfile)))
                                          (subrun-remove-succeeded
                                           (debug:print 0 *default-log-port* "Now removing of " test-fulln " with run-id " run-id " since subrun was removed.")
                                           ;;(runs:remove-test-directory new-test-dat mode) ;; let normal case handle this. it will go thru loop again as non-subrun
                                           )
                                          (else
                                           (let* ((logfile (subrun:get-log-path run-dir "remove")))
                                             (debug:print 0 *default-log-port* "WARNING: removal of subrun failed.  Please check "logfile" for details."))))
                                         ;;(if (not (null? tal))
                                         ;;    (loop (car tal)(cdr tal)))
                                         
                                         ;; send to back of line, loop (will not match has-subrun next time through)
                                       (let ((newtal (append tal (list test))))
                                        (loop (car newtal)(cdr newtal)))
                                         ))
                                      ) ; end case rem-status
                                    ) ; end let
                                  ); end cond has-subrun

                                 (else
                                  (debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state)
                                  (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
                                      (begin
                                        (if (not (hash-table-ref/default test-retry-time test-fulln #f))
                                            (begin
                                              ;; want to set to REMOVING BUT CANNOT do it here?
                                              (hash-table-set! test-retry-time test-fulln (current-seconds))))
                                        (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time)
                                            ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first
                                            ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give
                                            ;; up and blow it away.
                                            (begin
                                              (debug:print 0 *default-log-port* "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing")
                                              (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f)
                                              (thread-sleep! 1))
                                            (begin
                                              (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
                                        (runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
                                        (if (not (null? tal))
                                            (loop (car tal)(cdr tal)))))))
				(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
			       ((set-state-status)
                                ;; BB TODO - manage has-subrun case
				(debug:print-info 2 *default-log-port* "new state " (car state-status) ", new status " (cadr state-status))
				(mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f)
				(if (not (null? tal))
				    (loop (car tal)(cdr tal))))
			       ((run-wait)
                                ;; BB TODO - manage has-subrun case
				(debug:print-info 2 *default-log-port* "still waiting, " (length tests) " tests still running")
				(thread-sleep! 10)
				(let ((new-tests (proc-get-tests run-id)))
				  (if (null? new-tests)
				      (debug:print-info 1 *default-log-port* "Run completed according to zero tests matching provided criteria.")
				      (loop (car new-tests)(cdr new-tests)))))
			       ((archive)
                                ;; BB TODO - manage has-subrun case
				(if (and run-dir (not toplevel-with-children))
				    (let ((ddir (conc run-dir "/")))
				      (case (string->symbol (args:get-arg "-archive"))
					((save save-remove keep-html)
					 (if (common:file-exists? ddir)
					     (debug:print-info 0 *default-log-port* "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir)))))))
				(if (not (null? tal))

;; Copyright 2006-2016, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;;  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
     call-with-environment-variables)
(declare (unit subrun))
;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
;;(declare (uses items))
;;(declare (uses runconfig))
;;(declare (uses tests))
;;(declare (uses server))
(declare (uses mt))
;;(declare (uses archive))
;; (declare (uses filedb))

;(include "common_records.scm")
;;(include "key_records.scm")
(include "db_records.scm") ;; provides db:test-get-id
;;(include "run_records.scm")
;;(include "test_records.scm")

(define (subrun:subrun-test-initialized? test-run-dir)
  (if (and (common:file-exists? (conc test-run-dir "/subrun-area") )
           (common:file-exists? (conc test-run-dir "/testconfig.subrun") ))
      #t
      #f))

(define (subrun:subrun-removed? test-run-dir)
  (if (subrun:subrun-test-initialized? test-run-dir)
      (let ((flagfile (conc test-run-dir "/subrun.removed")))
        (if (common:file-exists? flagfile)
            #t
            #f))
      #t))

(define (subrun:set-subrun-removed test-run-dir)
  (let ((flagfile (conc test-run-dir "/subrun.removed")))
    (if (and (subrun:subrun-test-initialized? test-run-dir) (not (common:file-exists? flagfile)))
        (with-output-to-file flagfile
          (lambda () (print (current-seconds)))))))

(define (subrun:testconfig-defines-subrun? testconfig)
  (configf:lookup testconfig "subrun" "runwait")) ;; we use runwait as the flag that a subrun is requested

(define (subrun:initialize-toprun-test  testconfig test-run-dir)

  (let ((ra (configf:lookup testconfig "subrun" "run-area"))
        (logpro (configf:lookup testconfig "subrun" "logpro"))
        (symlink-target (conc test-run-dir "/subrun-area"))
        )
  (when (not ra)      ;; when runarea is not set we default to *toppath*. However 
              ;; we need to force the setting in the testconfig so it will
          ;; be preserved in the testconfig.subrun file
      (configf:set-section-var testconfig "subrun" "runarea" *toppath*))
    (configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun

    (if (common:file-exists? symlink-target)
        (delete-file symlink-target))
    
    (create-symbolic-link ra symlink-target)

    (configf:write-alist testconfig "testconfig.subrun")))


(define (subrun:remove-subrun test-run-dir keep-records )
;; set state/status of test item
;; fork off megatest
;; set state/status of test item
;;
  ;;(BB> "Entered subrun:remove-subrun with "test-fulln)
  (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir))
      (let* ((action-switches-str
              (conc "-remove-runs"
                    (if keep-records "-keep-records " "")
                    ))
             (remove-result
              (subrun:exec-sub-megatest test-run-dir action-switches-str "remove")))
        (if remove-result
            (begin
              (subrun:set-subrun-removed test-run-dir)
              #t)
            #f))
      #t))

(define (subrun:launch-cmd test-run-dir)
  (let* ((log-prefix "run")
         (switches (subrun:selector+log-switches test-run-dir log-prefix))
         (run-wait #t)
         (cmd      (conc "megatest -run "switches" "
                         (if run-wait "-run-wait " ""))))
    cmd))


(define (subrun:selector+log-alist test-run-dir log-prefix)
  (let* ((switch-def-alist (common:get-param-mapping flavor: 'config))
         (subrunfile   (conc test-run-dir "/testconfig.subrun" ))
         (subrundata   (with-input-from-file subrunfile read))
         (subrunconfig (configf:alist->config subrundata))
         (run-area     (configf:lookup subrunconfig "subrun" "run-area"))
         (defvals      `(("start-dir" . ,(or run-area  ;; default values if not specified in subrun section of tconf
                                             (get-environment-variable "MT_RUN_AREA_HOME")
                                             "/no/rundir/found")) 
                         ("run-name"  . ,(or (get-environment-variable "MT_RUNNAME") "NO-RUNNAME"))
                         ("target"    . ,(or (get-environment-variable "MT_TARGET")  "NO-TARGET"))))
         (switch-alist-pre  (filter-map (lambda (item)
                                          (let* ((config-key (car item))
                                                 (switch     (cdr item))
                                                 (defval     (alist-ref config-key defvals equal? #f))
                                                 (val        (or (configf:lookup subrunconfig "subrun" config-key)
                                                                 defval)))
                                            (if val
                                                (cons switch val)
                                                #f)))
                                        switch-def-alist))

         ;; testpatt may be modified if all three of mode-patt, tag-expr, and testpatt are null
         (mode-patt     (alist-ref "-modepatt" switch-alist-pre equal? #f))
         (tag-expr      (alist-ref "-tagexpr" switch-alist-pre equal? #f))
         (testpatt      (alist-ref "-testpatt" switch-alist-pre equal?
                                   (if (not (or mode-patt tag-expr)) "%" #f))) ;; testpatt is % if not
                                                                               ;; otherwise specified

         ;; define compact-stem for logfile
         (target        (alist-ref "-target" switch-alist-pre equal? #f)) ;; want data-structures alist-ref, not alist-lib alist-ref
         (runname       (alist-ref "-runname" switch-alist-pre equal? #f))


         (compact-stem  (string-substitute "[/*]" "_"
                                           (conc
                                            target
                                            "-"
                                            runname
                                            "-" (or testpatt mode-patt tag-expr "NO-TESTPATT"))))
         (logfile       (conc
                         test-run-dir "/"
                         (or log-prefix "")
                         (if log-prefix "-" "")
                         compact-stem
                         ".log"))
         ;; swap out testpatt with modified test-patt and add -log
         (switch-alist  (cons
                         (cons "-log" logfile)
                         (map (lambda (item)
                                (if (equal? (car item) "-testpatt")
                                    (cons "-testpatt" testpatt)
                                    item))
                                switch-alist-pre))))
    switch-alist))
    ;; note - get precmd from subrun section
    ;;   apply to submegatest commands

(define (subrun:get-log-path test-run-dir log-prefix)
  (let* ((alist (subrun:selector+log-alist test-run-dir log-prefix))
         (res   (alist-ref "-log" alist equal? #f)))
    res))

(define (subrun:selector+log-switches test-run-dir log-prefix)
  (let* ((switch-alist (subrun:selector+log-alist test-run-dir log-prefix))
         (res
          (string-intersperse
           (apply
            append
            (map
             (lambda (x)
               (list (car x) (cdr x)))
             switch-alist))
           " ")))
    res))

(define (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix)
  (let* ((selector-switches  (subrun:selector+log-switches test-run-dir log-prefix))
         (cmd (conc "megatest " selector-switches " " action-switches-str ))
         (pid #f)
         (proc (lambda ()
                 (debug:print-info 0 *default-log-port* "Running sub megatest command: "cmd)
                 ;;(set! pid (process-run "/usr/bin/xterm" (list ))))))
                 (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
    (call-with-environment-variables 
     (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
     (lambda  ()
       (common:without-vars proc "^MT_.*")))
    (let processloop ((i 0))
      (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
        (if (eq? pid-val 0)
            (begin
              (thread-sleep! 2)
              (processloop (+ i 1)))
            (begin
              (debug:print-info 0 *default-log-port* "sub megatest " action-switches-str " completed with exit code " exit-code)
              (if (eq? 0 exit-code)
                  (begin
                    #t)
                  (begin
                    #f))))))))



;; (subrun:exec-sub-megatest "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/165/megatest/ext-tests/tests/subrun-usecases/toparea/links/SYSTEM_val/RELEASE_val/go/toptest" "-foo" "foo")

                                  #f)))
    (if data-id
      (begin
        (if pgdb-test-id
           (begin 
                (if  pgdb-data-id
                   (begin
                    (print "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
                    (print "Updating existing test-data with test-id: " test-id " and  data-id " data-id " pgdb test id: " pgdb-test-id)
                    (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id  category variable value expected tol units comment status type))
                    (begin
 		      (print "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
                       (if (handle-exceptions
		      exn
		      (begin (print-call-chain)
                              (print ((condition-property-accessor 'exn 'message) exn))     
			#f)
                     
                      (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )
                      (set! pgdb-data-id  (pgdb:get-test-data-id dbh pgdb-test-id  category variable))))
                    (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type ))
		       ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
                      (begin
                      ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )
                      (set! pgdb-data-id  (pgdb:get-test-data-id dbh pgdb-test-id  category variable)))
		  (exit))))
                (hash-table-set! data-ht data-id pgdb-data-id ))
             (begin
                 (print "Error: Test not in pgdb"))))

      (print "Error: Could not get test data info for data id " test-data-id ))))	;; this is a wierd senario need to debug      	
   test-data-ids)))

                              (s:a  "next>> "  'href (conc  "dashboard?page="  (+ pg 2)  ))
                             (s:a "" 'href (conc  "dashboard?page=" pg  )))))
                             link)))
         (html-body (tests:dashboard-body pg pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #t)))
         ;(print (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name))
html-body))

(define (tests:create-html-summary outf)
 (let* ((lockfile  (conc outf ".lock"))
        (linktree  (common:get-linktree))
				(keys      (rmt:get-keys))
        (area-name (common:get-testsuite-name)))
    (if (common:simple-file-lock lockfile)
        (begin
          (let* ((runsdat   (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys)))
					       (runs      (vector-ref runsdat 1))
                 (header      (vector-ref runsdat 0))
        	       (oup       (open-output-file (or outf (conc linktree "/targets.html"))))
                 (target-hash (test:create-target-hash runs header (length keys))))
          (test:create-target-html target-hash oup area-name linktree)
          (test:create-run-html  runs area-name linktree (length keys) header))
	  (common:simple-file-release-lock lockfile))
	#f)))

(define (test:get-test-hash test-data)
	(let ((resh (make-hash-table)))
    	(map (lambda (test)
        (let* ((test-name (vector-ref test 2))
               (test-html-path (if (file-exists? (conc (vector-ref test 10) "/test-summary.html"))
																 (conc (vector-ref test 10) "/test-summary.html" )
							 									 (conc (vector-ref test 10) "/" (vector-ref test 13))))
               (test-item  (vector-ref test 11))
               (test-status (vector-ref test 4)))
               (if (not (hash-table-ref/default resh test-item  #f))
                   (hash-table-set! resh test-item   (make-hash-table)))
               (hash-table-set! (hash-table-ref/default resh test-item  #f) test-name (list test-status test-html-path)))) 
        test-data)
resh))

(define (test:get-data->b-keys ordered-data a-keys)
  (delete-duplicates
   (sort (apply
	  append
	  (map (lambda (sub-key)
		 (let ((subdat (hash-table-ref ordered-data sub-key)))
		   (hash-table-keys subdat)))
	       a-keys))
	 string>=?)))


(define (test:create-run-html runs area-name linktree numkeys header)
  (map (lambda (run)
		 (let* ((target (string-join (take (vector->list run) numkeys) "/"))
						(run-name (db:get-value-by-header run header "runname"))
						(oup (open-output-file (conc linktree "/" target "/" run-name "/run.html")))
            (run-id (db:get-value-by-header run header "id"))
            (test-data    (rmt:get-tests-for-run
				  								 run-id
                           "%"       ;; testnamepatt
				  								 '()        ;; states
				   								 '()        ;; statuses
				  								 	#f         ;; offset
				  						 			#f         ;; num-to-get
				   									#f         ;; hide/not-hide
				  								  #f         ;; sort-by
				   									#f         ;; sort-order
				   									#f         ;; 'shortlist                           ;; qrytype
                            0         ;; last update
				  									#f))
            (item-test-hash (test:get-test-hash test-data))
            (items  (hash-table-keys item-test-hash))
 						(test-names (test:get-data->b-keys item-test-hash items)))
    (s:output-new
	   oup
	   (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f)

		   (s:title "Runs View " run-name)
		   (s:body
		     (s:h1 "Runs View " )
         (s:h2 "Target" target)
				 (s:h2 "Run name" run-name)
         (s:table 'border 1
           (s:tr
           (s:td "Items")
           (map (lambda (test)
            (s:td test))
           test-names))  
           (map (lambda (item) 
					  (let* ((test-hash (hash-table-ref/default item-test-hash item  #f)))
								 (if test-hash
                  (begin
									(s:tr
					  			(s:td item)
            			(map (lambda (test)
						  		(let* ((test-details (hash-table-ref/default test-hash test  #f))
												(status (if test-details
																(car test-details)))
                        (link (if test-details 
														(cadr test-details))))
                  (if test-details
											(s:td 'class status
												(s:a 'href link status ))
                      (s:td "")))) 			
									test-names))))))
				  (sort items string<=?))))))
		(close-output-port oup)))
runs))

(define (test:create-target-hash runs header numkeys)
  (let ((resh (make-hash-table)))
   (for-each
     (lambda (run)
        (let* ((run-name (db:get-value-by-header run header "runname"))
               (target   (string-join (take (vector->list run) numkeys) "/"))
               (run-list (hash-table-ref/default resh target  #f)))
               
               (if (not run-list)
                   (hash-table-set! resh target   (list run-name))
                   (hash-table-set! resh target   (cons run-name run-list)))))
      runs)
   resh))

(define (test:get-max-run-cnt target-hash targets)
   (let* ((cnt 0 ))
   (map (lambda (target)
        (let* ((runs  (hash-table-ref/default target-hash target  #f))
               (run-length (if runs
																(length runs)
                                 0)))
  
              (if (< cnt run-length)
               (set! cnt  run-length)))) 
		targets) 
cnt))
 
(define (test:pad-runs target-hash targets max-row-length)
 (map (lambda (target)
        (let loop ((run-list  (hash-table-ref/default target-hash target  #f)))
               (if (< (length run-list) max-row-length)
                 (begin  
               		 (hash-table-set! target-hash target   (cons "" run-list))
               		 (loop (hash-table-ref/default target-hash target  #f) ))))) 
		targets)
   target-hash)

(define (test:create-target-html target-hash oup area-name linktree)
  (let* ((targets (hash-table-keys target-hash))
         (max-row-length (test:get-max-run-cnt target-hash targets))
         (pad-runs-hash (test:pad-runs target-hash targets max-row-length)))
   (s:output-new
	   oup
	   (s:html tests:css-jscript-block (tests:css-jscript-block-cond #f)

		   (s:title "Target View " area-name)
		   (s:body
		   (s:h1 "Target View " area-name)
					(s:table 'id "LinkedList1" 'border "1"
             (s:tr 'class "something" 
               (s:td "Target")
								(s:td 'colspan max-row-length "Runs"))                                              
                (let* ((tbl (map (lambda (target)
                      (s:tr
                      (s:td target)
										  (let* ((runs  (hash-table-ref/default target-hash target  #f))
														 (rest-row (map (lambda (run)
																				(if (equal? run "")
																						(s:td run)
																						(s:td 
																							(s:a 'href (conc linktree "/" target "/" run "/run.html") run))))
																				(reverse runs))))
                              rest-row)))
                                   targets)))
                           tbl)))))
          (close-output-port oup)))


(define (tests:create-html-tree-old outf)
   (let* ((lockfile  (conc outf ".lock"))
	 (runs-to-process '()))
    (if (common:simple-file-lock lockfile)
	(let* ((linktree  (common:get-linktree))