Megatest

                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE t.state='COMPLETED' AND r.target LIKE ? GROUP BY r.target;"
   target-patt))


(define (pgdb:get-latest-run-stats-given-target dbh ttype-id target-patt)
(define (pgdb:get-latest-run-stats-given-target dbh ttype-id target-patt limit offset)
  (dbi:get-rows
   dbh
   ;;    "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
   ;;         WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;"
   "SELECT r.target,COUNT(*) AS total,
   "SELECT r.target, r.event_time, COUNT(*) AS total,
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE t.state like '%'  AND ttype_id=? AND r.target LIKE ? 
                 and r.id in 
(SELECT DISTINCT on (target) id from runs where target like ? AND ttype_id=? order by target,event_time desc) GROUP BY r.target,r.id;"
   ttype-id target-patt target-patt ttype-id))
           (SELECT DISTINCT on (target) id from runs where target like ? AND ttype_id=? order by target,event_time desc) 
          GROUP BY r.target,r.id 
          order by r.event_time desc limit ? offset ? ;"
   ttype-id target-patt target-patt ttype-id limit offset))

(define (pgdb:get-latest-run-stats-given-pattern dbh patt limit offset)
  (dbi:get-rows
   dbh
   ;;    "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
   ;;         WHERE t.state='COMPLETED' AND ttype_id=? AND r.target ILIKE ? GROUP BY r.target,t.status;"
   "SELECT r.target, r.event_time, COUNT(*) AS total,
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE t.state like '%'  AND r.target ILIKE ? 
                 and r.id in 
           (SELECT DISTINCT on (target) id from runs where target ilike ?  order by target,event_time desc) 
          GROUP BY r.target,r.id 
          order by r.event_time desc limit ? offset ? ;"
   patt patt  limit offset))


(define (pgdb:get-count-data-stats-target-latest dbh ttype-id target-patt)
  (dbi:get-rows
   dbh
    "SELECT count(*)  from 
          (SELECT DISTINCT on (target) id 
		from runs where target like ? AND ttype_id = ? 
		order by target, event_time desc
          ) as x;" 
    target-patt ttype-id))

(define  (pgdb:get-latest-run-cnt dbh ttype-id target-patt)
  (let* ((cnt-result (pgdb:get-count-data-stats-target-latest dbh ttype-id target-patt))
         ;(cnt-row (car (cnt-result)))
         (cnt 0) 
       )
    (for-each
     (lambda (row)
      (set! cnt  (vector-ref row 0 ))) 
     cnt-result)

cnt))

(define (pgdb:get-count-data-stats-latest-pattern dbh patt)
  (dbi:get-rows
   dbh
    "SELECT count(*)  from 
          (SELECT DISTINCT on (target) id 
		from runs where target ilike ?  
		order by target, event_time desc
          ) as x;" 
    patt))

(define  (pgdb:get-latest-run-cnt-by-pattern dbh target-patt)
  (let* ((cnt-result (pgdb:get-count-data-stats-latest-pattern dbh target-patt))
         ;(cnt-row (car (cnt-result)))
         (cnt 0) 
       )
    (for-each
     (lambda (row)
      (set! cnt  (vector-ref row 0 ))) 
     cnt-result)

cnt))





(define (pgdb:get-run-stats-history-given-target dbh ttype-id target-patt)
  (dbi:get-rows
   dbh
   ;;    "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
   ;;         WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;"
   "SELECT r.run_name,COUNT(*) AS total,
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE t.state like '%'  AND ttype_id=? AND r.target LIKE ? 
                 GROUP BY r.run_name;"
   ttype-id target-patt ))

(define (pgdb:get-all-run-stats-target-slice dbh target-patt)
(dbi:get-rows
   dbh
   "SELECT  r.target, r.run_name,r.event_time, COUNT(*) AS total,
(define (pgdb:get-all-run-stats-target-slice dbh target-patt limit offset)
    (dbi:get-rows
    dbh
    "SELECT  r.target, r.run_name,r.event_time, COUNT(*) AS total,
                    SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
                    SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
                    SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE r.target LIKE ? 
            GROUP BY r.target,r.run_name, r.event_time
             order by r.target,r.event_time desc limit  ? offset ?   ;"
    target-patt limit offset))
             
            GROUP BY r.target,r.run_name, r.event_time;"
     

(define (pgdb:get-count-data-stats-target-slice dbh target-patt)
  (dbi:get-rows
   dbh
    "SELECT count(*)  from (SELECT  r.target, r.run_name,r.event_time, COUNT(*) AS total
            FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
            WHERE r.target LIKE ?
            GROUP BY r.target,r.run_name, r.event_time 
          ) as x;" 
    target-patt))

(define  (pgdb:get-slice-cnt dbh target-patt)
  (let* ((cnt-result (pgdb:get-count-data-stats-target-slice dbh target-patt))
         ;(cnt-row (car (cnt-result)))
         (cnt 0) 
       )
    (for-each
     (lambda (row)
      (set! cnt  (vector-ref row 0 ))) 
     cnt-result)

cnt))
   

(define (pgdb:get-target-types dbh)
  (dbi:get-rows dbh "SELECT id,target_spec FROM ttype;"))
 
 (define (pgdb:get-distict-target-slice dbh)
  (dbi:get-rows dbh " select distinct on (split_part (target, '/', 1)) (split_part (target, '/', 1)) from runs;"))


  (define (pgdb:get-distict-target-slice3 dbh)
  (dbi:get-rows dbh " select distinct on (split_part (target, '/', 3)) (split_part (target, '/', 3)) from runs;"))
;; 
(define (pgdb:get-targets dbh target-patt)
  (let ((ttypes (pgdb:get-target-types dbh)))
    (map
     (lambda (ttype-dat)
       (let ((tt-id (vector-ref ttype-dat 0))
	     (ttype (vector-ref ttype-dat 1)))

;; create a hash of hashes with keys extracted from all-parts
;; using row-or-col to choose row or column
;;   ht{row key}=>ht{col key}=>data
;;
;; fnum is the field number in the tuples to be split
;;

(define (pgdb:mk-pattern  dot type bp rel)
  (let* ((typ (if (equal? type "all")
               "%"
                type))
        (dotprocess (if (equal? dot "all")
                      "%"
                     dot))
        (rel-num (if (equal? rel "")
                      "%"
                     rel))
        (pattern  (conc "%/" bp "/" dotprocess "/" typ "_" rel-num)))
pattern))

(define (pgdb:coalesce-runs dbh runs all-parts row-or-col fnum)
  (let* ((data  (make-hash-table)))
    ;;	 (rnums (
    
    ;; for now just do first => remainder
    (for-each
     (lambda (run)
       (let* ((target (vector-ref run fnum))
	      (parts  (string-split target "/"))
	      (first  (car parts))
	      (rest   (string-intersperse (cdr parts) "/"))
	      (coldat (hash-table-ref/default data first #f)))
	 (if (not coldat)(let ((newht (make-hash-table)))
			   (hash-table-set! data first newht)
			   (set! coldat newht)))
	 (hash-table-set! coldat rest run)))
     runs)
    data))


(define (pgdb:coalesce-runs1 runs  )
  (let* ((data  (make-hash-table)))
    
    (for-each
     (lambda (run)
       (let* ((target (vector-ref run 0))
	      (parts  (string-split target "/"))
	      (first  (car parts))
	      (rest   (string-intersperse (cdr parts) "/"))
	      (coldat (hash-table-ref/default data first #f)))
	 (if (not coldat)(let ((newht (make-hash-table)))
			   (hash-table-set! data first newht)
			   (set! coldat newht)))
	 (hash-table-set! coldat rest run)))

  (let* ((data  (make-hash-table)))
     (for-each
     (lambda (run)
       (let* ((run-name (vector-ref run 0)))
	 (hash-table-set! data run-name run)))
     runs)
    data))

(define (pgdb:get-pg-lst tab2-pages)
    (let loop ((i 1)
             (lst `()))
                       (cond
                        ((> i tab2-pages )
                        lst) 
                      (else 
		  	(loop (+ i 1) (append   lst (list i)))))))

(define *p* '("a" "b" "c"))
(define *k* '("all" "a"))
(define *d* '("all" 1 2 3 6 5 8 11 12))

;;======================================================================
;; Copyright 2017, 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.
;;======================================================================

(use regex)
(load "models/pgdb.scm")
(include "pages/filter-defs.scm")
(include "pages/home_ctrl.scm")
(include "pages/home_view.scm")

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

;; a function <pagename>-action is called on POST

(define (home-action action)
  (case (string->symbol action)
    ((filter)
     (let ((target-type   (s:get-input 'target-type))
	   (target-filter (s:get-input 'tfilter))
	   (target        (s:get-input 'target))
	   (row-or-col    (s:get-input 'row-or-col)))
     (let ((dot   (s:get-input 'dot))
	   (type (s:get-input 'kit-type))
	   (rel        (s:get-input 'rel-num))
           (bp (s:get-input 'bp)))
       ;;
       ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea.
       ;;
       (s:set! "row-or-col" (if (list? row-or-col)
       
				(string-intersperse row-or-col ",")
				row-or-col))
       (s:set! "target-type" target-type)
       (s:set! "tfilter" target-filter)
       (s:set! "target"  target)
       (s:set! "target-filter" target-filter)))
       (s:set! "dot" dot)
       (s:set! "type"  type)
       (s:set! "bp"  bp)

((filter2)
     (let ((tslice-select   (s:get-input 'tslice-select))
	   (t-slice-filter (s:get-input 't-slice-filter)))
       ;;
       ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea.
       ;;
       (s:set! "tslice" tslice-select)
       (s:set! "rel" rel)))))
       (s:set! "t-slice-patt" t-slice-filter)))
))

;;======================================================================
;; Copyright 2017, 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.
;;======================================================================

(define (pages:home session db shared)
  
  (let* ((dbh         (s:db))
         (limit 50)
         (curr-page   (if (or (equal? (s:get-param "pg") "") (equal? (s:get-param "pg") #f))
                      1
                        (string->number (s:get-param "pg"))))
	 (ttypes      (pgdb:get-target-types dbh))
	 (selected    (string->number (or (s:get "target-type") "-1")))
         (target-slice (pgdb:get-distict-target-slice dbh)) 
         (selected-slice (or (s:get "tslice") ""))  
         
         (offset (- (* limit  curr-page) limit))     
         (dot    (if (s:get-param "dot")
                           (string->number (s:get-param "dot"))
                           (if (and  (s:get "dot") (not (equal? (s:get "dot") "all")))
                             (string->number (s:get "dot"))
                              "all")))
         (type    (if (s:get-param "type")
                           (s:get-param "type")
	 (curr-trec   (filter (lambda (x)(eq? selected (vector-ref x 0))) ttypes))
	 (curr-ttype  (if (and selected
			       (not (null? curr-trec)))
			  (vector-ref (car curr-trec) 1) #f))
                       (if (and (s:get "type") (not (equal? (s:get "type") "all")))
                              (s:get "type")
                              "all")))
	 (all-parts   (if curr-ttype (append (string-split curr-ttype "/") '("runname" "testname")) '()))
	 (tfilter     (or (s:get "target-filter") "%"))
         (tslice-filter     (or (s:get "t-slice-patt") ""))
         (target-patt   (if (or (equal? selected-slice "") (equal? tslice-filter "" ))
                             "" 
          (bp    (if (s:get-param "bp")
                           (s:get-param "bp")
                       (if (s:get "bp") 
                              (s:get "bp")
                              "p1273")))
           (rel    (if (s:get-param "rel")
                           (s:get-param "rel")
                       (if (and  (s:get "rel") (not (equal? (s:get "rel") "all")))
                              (s:get "rel")
                              ""))) 
                           (conc selected-slice "/" tslice-filter )))
         (tab2-data (if (equal? target-patt "")
          (pattern  (pgdb:mk-pattern dot type bp rel)) 	 
                         `()
                         (pgdb:get-all-run-stats-target-slice dbh target-patt)))
         (tab2-ordered-data (pgdb:coalesce-runs-by-slice tab2-data selected-slice))  
	 (targets     (pgdb:get-targets-of-type dbh selected tfilter))
	 (row-or-col  (string-split (or (s:get "row-or-col") "") ","))
	; (targets     (pgdb:get-targets-of-type dbh selected tfilter))
	            
	 (all-data    (if (and selected
			       (not (eq? selected -1)))
                          (pgdb:get-latest-run-stats-given-target dbh selected tfilter)
                           '()  
	 (all-data       (pgdb:get-latest-run-stats-given-pattern dbh pattern  limit offset))
                           ;'()  )
			 ; (pgdb:get-stats-given-type-target dbh selected tfilter)
			 ; (pgdb:get-stats-given-target dbh tfilter)
			  ))
  (ordered-data (pgdb:coalesce-runs dbh all-data all-parts row-or-col 0)))
			  
         (cnt     (pgdb:get-latest-run-cnt-by-pattern dbh pattern))
         (total-pages (ceiling (/ cnt  limit))) 
         (page-lst (pgdb:get-pg-lst total-pages))
         (ordered-data (pgdb:coalesce-runs1 all-data))
         (rel-val (if (equal? rel "")
                       "%"
                        rel)))
   (s:div 'class "col_12" 
        (s:ul 'class "tabs left"
      	(s:li (s:a 'href "#tabr1" "Sliced Filter"))
          
        (s:li (s:a 'href "#tabr2" "Genral Filter")))
  (s:div 'id "tabr1" 'class "tab-content"
      (s:div 'class "col_11" 
      (s:fieldset    "Filter Targets by slice"
	    (s:form
	     'action "home.filter2" 'method "post"
	     (s:div 'class "col_12"
		    (s:div 'class "col_6"
			   (s:select (map (lambda (x)
        (map (lambda (x)
					    (let ((t-slice (vector-ref x 0)))
					      (if (equal? t-slice selected-slice)
						  (list t-slice t-slice t-slice #t)
						  (list t-slice t-slice t-slice #f))))
					  target-slice)
				     'name 'tslice-select))
		    (s:div 'class "col_4"
			   (s:input-preserve 'name "t-slice-filter" 'placeholder "Filter remainder target"))
		    (s:div 'class "col_2"
			   (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit")))))
      (s:br) 
            	(s:li (s:a 'href (conc "#" x) x)))
      (s:p "  Result Format:   total / pass / fail / other")
      (s:fieldset	    (conc "Runs data for " target-patt) 
          (let* ((target-keys (hash-table-keys tab2-ordered-data))
		  (run-keys (delete-duplicates (apply  append (map (lambda (sub-key)
					 (let ((subdat (hash-table-ref  tab2-ordered-data sub-key)))
					   (hash-table-keys subdat)))
				       target-keys)))))
            (s:table  'class "striped"
		   (s:tr  (s:th  'class "heading" ) 
 			(map
                	(lambda (th-key) 
                         (s:th 'class "heading" th-key )) 
	  *process*))
       (map (lambda (x)
        
                    run-keys))
		   (map
		    (lambda (row-key)
		      (s:tr (s:td row-key)
			    (map
			     (lambda (col-key)
			       (let ((val (let* ((ht  (hash-table-ref/default  tab2-ordered-data row-key #f)))
					    (if ht (hash-table-ref/default ht col-key #f)))))
				 (if val
				     (let* ((total (vector-ref val 3))
					    (pass  (vector-ref val 4))
					    (fail  (vector-ref val 5))
					    (other (vector-ref val 6))
					    (passper (round (* (/ pass total) 100)))
					    (target-param (string-substitute "[/]" "_x_" (conc selected-slice "/" row-key) 'all)))
				       (s:td   'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);")
      				      (s:a 'class "white"  'href (s:link-to "run" 'target target-param 'run col-key)
(conc  total "/" pass "/" fail "/" other))))
				     (s:td ""))))
			     run-keys)))
		    target-keys))
))
))
    (s:div 'id "tabr2" 'class "tab-content"
       (s:div 'id  x 'class "tab-content"
      (s:div 'class "col_11"
	   (s:fieldset    "Area type and target filter"
	    (s:form
	     'action "home.filter#tabr2" 'method "post"
	     'action (conc "home.filter#" x) 'method "post"
	     (s:div 'class "col_12"
		    (s:div 'class "col_6"
			   (s:select (map (lambda (x)
					    (if x
						(let ((tt-id (vector-ref x 0))
						      (ttype (vector-ref x 1)))
						  (if (eq? tt-id selected)
						      (list ttype tt-id ttype #t)
						      (list ttype tt-id ttype #f)))
                        (s:div 'class "col_3"
			   (s:label "Release Type") (s:select (map (lambda (x)
                                           (if (equal?  x type)  
                                            (list x x x #t)
                                            (list x x x #f)) )
					  *kit-types*)
				     'name "kit-type"))
                   (s:div 'class "col_3"
			   (s:label "Dot") (s:select (map (lambda (x)
                                            (if (equal?  x dot)  
                                            (list x x x #t)
                                            (list x x x #f)))
						(list "all" -1 "all" (eq? selected -1))))
					  (cons #f ttypes))
				     'name 'target-type))
		    (s:div 'class "col_4"
			   (s:input-preserve 'name "tfilter" 'placeholder "Filter targets"))
					  *dots*)
				     'name "dot"))

		   (s:div 'class "col_3"
                            (s:input 'type "hidden" 'value x 'name "bp")
			   (s:label "Release #") (s:input 'type "text" 'name "rel-num" 'value rel-val))
		    (s:div 'class "col_2"
			   (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit")))))
           (s:br) 
           (s:br)
           ;(s:p (conc dot(string? dot) )) 
             (s:p (map
            (lambda (i) 
          (s:span (s:a 'href (s:link-to "home" 'pg i ) "PAGE " i  )" | "))  
          page-lst))
           (s:p "  Result Format:   total / pass / fail / other")
            (if (equal? x bp)
             (begin 
           	   (s:fieldset	    (conc "Runs data for " tfilter)
           (s:fieldset	    (conc "Runs data for " pattern)
	    ;;
	    ;; A very basic display
	    ;;
	    (let* ((a-keys (pgdb:ordered-data->a-keys ordered-data))
	      (let* ((a-keys (pgdb:ordered-data->a-keys ordered-data))
		   (b-keys (pgdb:ordered-data->b-keys ordered-data a-keys)))
	      ;; (c-keys (delete-duplicates b-keys)))
	      (if #f ;; swap rows/cols
		  (s:table
		    (s:tr (s:td "")(map s:tr b-keys))
		   (map
		    (lambda (row-key)
		      (let ((subdat (hash-table-ref ordered-data row-key)))
			(s:tr (s:td row-key)
			      (map
			       (lambda (col-key)
				 (s:td (let ((dat (hash-table-ref/default subdat col-key #f)))
					 (s:td (if dat
						   (list (vector-ref dat 0)(vector-ref dat 1))
						   "")))))
			       b-keys))))
		    a-keys))
		  (s:table  'class "striped"
  		  (s:table  'class "striped"
		   (s:tr  (s:th  'class "heading" ) 
 			(map
                	(lambda (th-key) 
                         (s:th 'class "heading" th-key )) 
                    a-keys))
		   (map
		    (lambda (row-key)
		      (s:tr (s:td row-key)
			    (map
			     (lambda (col-key)
			       (let ((val (let* ((ht  (hash-table-ref/default ordered-data col-key #f)))
					    (if ht (hash-table-ref/default ht row-key #f)))))
				 (if val
				     (let* ((total (vector-ref val 1))
					    (pass  (vector-ref val 2))
					    (fail  (vector-ref val 3))
					    (other (vector-ref val 4))
                                            (id (vector-ref val 5)) 
				     (let* ((total (vector-ref val 2))
                                            (event-time (vector-ref val 1)) 
					    (pass  (vector-ref val 3))
					    (fail  (vector-ref val 4))
					    (other (vector-ref val 5))
                                            (id (vector-ref val 6)) 
					    (passper (round (* (/ pass total) 100)))
					    (failper (- 100 passper))
                                             (history (pgdb:get-run-stats-history-given-target dbh selected (conc col-key "/" row-key)))  
                                             (history (pgdb:get-run-stats-history-given-target dbh 1 (conc col-key "/" row-key)))  
         				     (history-hash (pgdb:get-history-hash history))
                                             (history-keys (sort (hash-table-keys history-hash) string>=?))
					    (run-key (string-substitute "[/]" "_x_" (conc col-key "/" row-key) 'all)))
				       (s:td   'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);")
      				      (s:a 'class "white"  'href (s:link-to "run" 'target run-key)
					  (conc "Latest:" total "/" pass "/" fail "/" other)) (s:span " | ") (s:a 'id id 'class "viewmodal"  'title "Click to see description"  "History") (s:br)
					  (conc "Latest:" total "/" pass "/" fail "/" other)) (s:span "  | ") (s:a 'id id 'class "viewmodal"  'title "Click to see description"  "History") (s:br)
                                   (s:div 'id (conc "myModal" id) 'class "modal"
                                        (s:div 'class "modal-content"
                                             (s:span 'id id 'class "close" "×") 
    						;(s:p (conc "Modal " id ".."))
                                                 (s:div                                                  
                                                          (s:table 
                                                             (s:tr

                                                                         (hpass (vector-ref history-row 2))
                                                                         (hfail (vector-ref history-row 3))
                                                                         (hother (vector-ref history-row 4))
                                                                         (passper (round (* (/ hpass htotal) 100))))
                                                                (s:tr (s:td  history-key)
                                                                      (s:td 'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);")
(conc  htotal "/" hpass "/" hfail "/" hother )))))
                                                              history-keys)))
                                                              history-keys)))))))

))
 ))
				     (s:td ""))))
			     a-keys)))
		    b-keys)))))))
)))
		    b-keys))))
)
(begin 
(s:p ""))))))
 *process*))))

;;======================================================================
;; Copyright 2017, 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.
;;======================================================================

(use regex)

;; (load "models/pgdb.scm")
(include "pages/index_ctrl.scm")
(include "pages/index_view.scm")
(include  "pages/index_ctrl.scm")
(include  "pages/index_view.scm")

<script type="text/javascript" src="https://ajax.googleapis.com/ajax/libs/jquery/1.6.4/jquery.min.js"></script>
<!--[if lt IE 9]><script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script><![endif]-->
EOF
))

(define index:javascript
#<<EOF
<script type="text/javascript" src="/js/prettify.js"></script>                                   <!-- PRETTIFY -->
<!-- <script type="text/javascript" src="/js/prettify.js"></script>                                  PRETTIFY -->
<script type="text/javascript" src="/js/kickstart.js"></script>                                  <!-- KICKSTART -->
<script type="text/javascript" src="/js/pjhatwal-modal.js "></script>                          <!-- Modal -->
EOF
)

	  (s:title (conc "Megatest")) 
	  (s:head
	   index:kickstart-junk
	   ) 
	  (s:body
	   (s:div 'class "grid flex" 'id "top_of_page"
		  ;; add visible to columns to help visualize them e.g. "col_12 visible"
                  (s:ul 'class "menu"
(s:li (s:a 'href ""  (s:i 'class "fa fa-inbox") "QA Summary")
      (s:ul
	(s:li (s:a 'href "/cgi-bin/megatest.sh/home"  "Component Snapshot"))
        (s:li (s:a 'href "/cgi-bin/megatest.sh/kitprogress"  "Kit/Contour progress"))
 )))
;(s:li (s:a 'href (s:link-to "run" ) "Runs"))) 
		  (case (string->symbol page-name)
		    ((index)  (s:call "home"))
		    (else     (s:call page-name))))
	   index:jquery
	   index:javascript
	   ))))))

    (8 "RUNNING")
    ))

(define *common:std-statuses*
  '(;; (0 "DELETED")
    (1 "n/a")
    (2 "PASS")
    (3 "CHECK")
    (4 "SKIP")
    (5 "WARN")
    (6 "WAIVED")
    (3 "SKIP")
    (4 "WARN")
    (5 "WAIVED")
    (6 "CHECK")
    (7 "STUCK/DEAD")
    (8 "FAIL")
    (9 "ABORT")))

(define *common:ended-states*       ;; states which indicate the test is stopped and will not proceed
  '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE"))

  ;; runs
  ((allruns         '())                 : list)        ;; list of dboard:rundat records
  ((allruns-by-id    (make-hash-table))  : hash-table)  ;; hash of run-id -> dboard:rundat records
  ((done-runs       '())                 : list)        ;; list of runs already drawn
  ((not-done-runs   '())                 : list)        ;; list of runs not yet drawn
  (header            #f)                                ;; header for decoding the run records
  (keys              #f)                                ;; keys for this run (i.e. target components)
  ((numruns          (string->number (or (args:get-arg "-cols") "10")))                 : number)      ;; 
  ((numruns          (string->number (or (args:get-arg "-cols")
					 (configf:lookup *configdat* "dashboard" "cols")
					 "8")))                 : number)      ;; 
  ((tot-runs          0)                 : number)
  ((last-data-update  0)                 : number)      ;; last time the data in allruns was updated
  ((last-runs-update  0)                 : number)      ;; last time we pulled the runs info to update the tree
  (runs-mutex         (make-mutex))                     ;; use to prevent parallel access to draw objects
  ((run-update-times  (make-hash-table)) : hash-table)  ;; update times indexed by run-id
  ((last-test-dat      (make-hash-table)) : hash-table)  ;; cache last tests dat by run-id
  ((run-db-paths      (make-hash-table)) : hash-table)  ;; cache the paths to the run db files

  ;; Runs view
  ((buttondat         (make-hash-table)) : hash-table)  ;;     
  ((item-test-names  '())                : list)        ;; list of itemized tests
  ((run-keys          (make-hash-table)) : hash-table)
  (runs-matrix        #f)                               ;; used in newdashboard
  ((start-run-offset   0)                : number)      ;; left-right slider value
  ((start-test-offset  0)                : number)      ;; up-down slider value
  ((runs-btn-height    (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string)  ;; was 12
  ((runs-btn-fontsz    (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string)   ;; was 8
  ((runs-cell-width    (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string)   ;; was 50
  ((runs-cell-width    (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string)   ;; was 50
  ((all-test-names     '())              : list)
  
  ;; Canvas and drawing data
  (cnv                #f)
  (cnv-obj            #f)
  (drawing            #f)
  ((run-start-row     0)                 : number)

			      ;; #:size "10x30"
			      ))
	 (tb
          (iup:treebox
           #:value 0
           #:name "Runs"
           #:expand "YES"
           #:addexpanded "NO"
           #:addexpanded "YES"
           #:size "10x"
           #:selection-cb
           (lambda (obj id state)
             (debug:catch-and-dump
              (lambda ()
                (let* ((run-path (tree:node->path obj id))
                       (run-id    (tree-path->run-id tabdat (cdr run-path))))

      (dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
      (dcommon:command-testname-selector commondat tabdat update-keyvals))
     (iup:vbox
      (iup:split
       #:orientation "HORIZONTAL"
       #:value 800
      (let* ((cnv-obj (iup:canvas 
		       ;; #:size "500x400"
		       ;; #:size "250x250" ;; "500x400"
		       #:expand "YES"
		       #:scrollbar "YES"
		       #:posx "0.5"
		       #:posy "0.5"
		       #:action (make-canvas-action
				  (lambda (c xadj yadj)
				    (debug:catch-and-dump

		       )))
	cnv-obj)
      (let* ((hb1 (iup:hbox))
             (graph-cell-table (dboard:tabdat-graph-cell-table tabdat))
             (changed #f)
             (graph-matrix (iup:matrix
                           #:alignment1 "ALEFT"
                           #:expand "YES" ;; "HORIZONTAL"
                           ;; #:expand "YES" ;; "HORIZONTAL"
                           #:scrollbar "YES"
                           #:numcol 10
                           #:numlin 20
                           #:numcol-visible (min 8)
                           #:numcol-visible 5 ;; (min 8)
                           #:numlin-visible 1
                           #:click-cb
                           (lambda (obj row col status)
                             (let*
                                 ((graph-cell (conc row ":" col))
                                 (graph-dat   (hash-table-ref/default graph-cell-table graph-cell #f))
                                 (graph-flag  (dboard:graph-dat-flag graph-dat)))

;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))
  (let* ((rawconfig        (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
	 (changed          #f))
    (iup:vbox
     (iup:split
      #:value 500
      #:value 300
      (iup:frame 
       #:title "General Info"
       (iup:vbox
	(iup:hbox
	 (iup:label "Area Path")
	 (iup:textbox #:value *toppath* #:expand "HORIZONTAL"))
	(iup:hbox 

;; 
(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
  (let* ((update-mutex (dboard:commondat-update-mutex commondat))
	 (tb      (iup:treebox
		   #:value 0
		   #:name "Runs"
		   #:expand "YES"
		   #:addexpanded "NO"
		   #:addexpanded "YES"
		   #:selection-cb
		   (lambda (obj id state)
		     (debug:catch-and-dump
		      (lambda ()
			;; (print "obj: " obj ", id: " id ", state: " state)
			(let* ((run-path (tree:node->path obj id))
			       (run-id   (tree-path->run-id tabdat (cdr run-path))))

      run-matrix)
     (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel))))

;;======================================================================
;; R U N S 
;;======================================================================

(define (dboard:squarify toggles size)
  (let loop ((hed (car toggles))
	     (tal (cdr toggles))
	     (cur '())
	     (res '()))
    (let* ((ovrflo (>= (length cur) size))
	   (newcur (if ovrflo
		       (list hed)
		       (cons hed cur)))
	   (newres (if ovrflo
		       (cons cur res)
		       res)))
      (if (null? tal)
	  (if ovrflo
	      newres
	      (cons newcur res))
	  (loop (car tal)(cdr tal) newcur newres)))))

(define (dboard:make-controls commondat tabdat #!key (extra-widget #f) )
  (let ((btn-fontsz  (dboard:tabdat-runs-btn-fontsz tabdat)))
    (iup:hbox
     (iup:vbox
      (iup:frame 
       #:title "filter test and items"
       (iup:vbox

					 #:action (lambda (obj val index lbstate)
						    (set! *tests-sort-reverse* index)
						    (mark-for-update tabdat))))
		(default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
                
	   (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd)
	   
	   (set! hide-empty (iup:button "HideEmpty"
					;; #:expand HORIZONTAL"
					#:expand "NO" #:size "80x15"
					#:action (lambda (obj)
						   (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat)))
						   (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE"))
						   (mark-for-update tabdat))))
	   ;; (set! hide-empty (iup:button "HideEmpty"
	   ;; 				;; #:expand HORIZONTAL"
	   ;; 				#:expand "NO" #:size "80x15"
	   ;; 				#:action (lambda (obj)
	   ;; 					   (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat)))
	   ;; 					   (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE"))
	   ;; 					   (mark-for-update tabdat))))
	   (set! hide (iup:button "Hide"
				  #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
					     ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide"))
					     (iup:attribute-set! hide "BGCOLOR" sel-color)
					     (iup:attribute-set! show "BGCOLOR" nonsel-color)

            (iup:hbox)) ;; empty widget

        

        
        )))

     (iup:frame 
      #:title "state/status filter"
      (iup:vbox
       (apply 
	iup:hbox
	(map (lambda (status)
	       (iup:toggle (conc status "  ")
			   #:fontsize btn-fontsz ;; "10"
			   #:expand "HORIZONTAL"
			   #:action   (lambda (obj val)
					(mark-for-update tabdat)
					(if (eq? val 1)
					    (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t)
					    (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status))
					(set-bg-on-filter commondat tabdat))))
	     (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
     (let* ((status-toggles (map (lambda (status)
				   (iup:toggle (conc status)
					       #:fontsize 8 ;; btn-fontsz ;; "10"
					       ;; #:expand "HORIZONTAL"
					       #:action   (lambda (obj val)
							    (mark-for-update tabdat)
							    (if (eq? val 1)
								(hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t)
								(hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status))
							    (set-bg-on-filter commondat tabdat))))
				 (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
       (apply 
	iup:hbox
	(map (lambda (state)
	       (iup:toggle (conc state "  ")
			   #:fontsize btn-fontsz
			   #:expand "HORIZONTAL"
			   #:action   (lambda (obj val)
					(mark-for-update tabdat)
					(if (eq? val 1)
					    (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t)
					    (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state))
					(set-bg-on-filter commondat tabdat))))
	     (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
       (iup:valuator #:valuechanged_cb (lambda (obj)
					 (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
					       (oldmax   (string->number (iup:attribute obj "MAX")))
					       (maxruns  (dboard:tabdat-tot-runs tabdat)))
					   (dboard:tabdat-start-run-offset-set! tabdat val)
					   (mark-for-update tabdat)
					   (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
					   (iup:attribute-set! obj "MAX" (* maxruns 10))))
		     #:expand "HORIZONTAL"
		     #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
		     #:min 0
		     #:step 0.01)))
     ;;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1))))
	    (state-toggles  (map (lambda (state)
				   (iup:toggle (conc state)
					       #:fontsize 8 ;; btn-fontsz
					       ;; #:expand "HORIZONTAL"
					       #:action   (lambda (obj val)
							    (mark-for-update tabdat)
							    (if (eq? val 1)
								(hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t)
								(hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state))
							    (set-bg-on-filter commondat tabdat))))
				 (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
	    (num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3)))))
       (iup:vbox
	(iup:hbox
	 (iup:frame
	  #:title "states"
	  (apply
	   iup:hbox
	   (map (lambda (colgrp)
		  (apply iup:vbox colgrp))
		(dboard:squarify state-toggles 3))))
	 (iup:frame
	  #:title "statuses"
	  (apply
	   iup:hbox
	   (map (lambda (colgrp)
		  (apply iup:vbox colgrp))
		(dboard:squarify status-toggles 3)))))
	;; 
	;; (iup:frame 
	;; 	#:title "state/status filter"
	;; 	(iup:vbox
	;; 	 (apply
	;; 	  iup:hbox
	;; 	  (map
	;; 	   (lambda (status-toggle state-toggle)
	;; 	     (iup:vbox
	;; 	      status-toggle
	;; 	      state-toggle))
	;; 	   status-toggles state-toggles))

	;; horizontal slider was here
	
	)))))

(define (dashboard:runs-horizontal-slider tabdat )
  (iup:valuator #:valuechanged_cb (lambda (obj)
				    (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
					  (oldmax   (string->number (iup:attribute obj "MAX")))
					  (maxruns  (dboard:tabdat-tot-runs tabdat)))
				      (dboard:tabdat-start-run-offset-set! tabdat val)
				      (mark-for-update tabdat)
				      (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
				      (iup:attribute-set! obj "MAX" (* maxruns 10))))
		#:expand "HORIZONTAL"
		#:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
		#:min 0
		#:step 0.01))

					;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0))))
     )))

(define (dashboard:popup-menu  run-id test-id target runname test-name testpatt item-test-path test-info)
  (iup:menu 
   (iup:menu-item
    "Test Control Panel"
    #:action
    (lambda (obj)

    (iup:show
     (iup:dialog 
      #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
      #:menu (dcommon:main-menu)
      (let* ((runs-view (iup:vbox
			 (iup:split
			  #:orientation "VERTICAL" ;; "HORIZONTAL"
			  #:value 150
			  #:value 100
			  (dboard:runs-tree-browser commondat runs-dat)
			  (iup:split
			   #:value 100
			   ;; left most block, including row names
			   (apply iup:vbox lftlst)
			   ;; right hand block, including cells
			   (iup:vbox
			    #:expand "YES"
			    ;; the header
			    (apply iup:hbox (reverse hdrlst))
			    (apply iup:hbox (reverse bdylst)))))
			    (apply iup:hbox (reverse bdylst))
			    (dashboard:runs-horizontal-slider runs-dat))))
			 controls
			 ))
	     (views-cfgdat (common:load-views-config))
	     (additional-tabnames '())
	     (tab-start-num       5)   ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
	     ;; (data (dboard:tabdat-init (make-d:data)))
	     (additional-views 	;; process views-dat

					       "tabchangepos"))
			  (dashboard:summary commondat stats-dat tab-num: 0)
			  runs-view
			  (dashboard:runs-summary commondat onerun-dat tab-num: 2)
			  ;; (dashboard:new-view db data new-view-dat tab-num: 3)
			  (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
			  (dashboard:run-times commondat runtimes-dat tab-num: 4)
			  ;; (dashboard:runs-summary commondat onerun-dat tab-num: 4)
			  additional-views)))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Summary")
	(iup:attribute-set! tabs "TABTITLE1" "Runs")
	(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
	(iup:attribute-set! tabs "TABTITLE3" "Run Control")
	(iup:attribute-set! tabs "TABTITLE4" "Run Times")

;; Section to table
(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f))
  (let* ((curr-row-num    1)
         (key-vals        (configf:section-vars rawconfig sectionname))
         (section-matrix  (iup:matrix
                           #:alignment1 "ALEFT"
                           #:expand "YES" ;; "HORIZONTAL"
                           ;; #:expand "YES" ;; "HORIZONTAL"
                           #:numcol 1
                           #:numlin (length key-vals)
                           #:numcol-visible 1
                           #:numlin-visible (min 10 (length key-vals))
			   #:scrollbar "YES")))
    (iup:attribute-set! section-matrix "0:0" varcolname)
    (iup:attribute-set! section-matrix "0:1" valcolname)

				      (hash-table-set! tests-draw-state 'scalef (+ scalef
										   (if (> step 0)
										       (* scalef 0.01)
										       (* scalef -0.01))))
				      (if the-cnv
					  (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records))
				      ))
		       ;; #:size "50x50"
		       ;; #:size "250x250"
		       #:expand "YES"
		       #:scrollbar "YES"
		       #:posx "0.5"
		       #:posy "0.5"
		       #:button-cb (lambda (obj btn pressed x y status)
				     ;; (print "obj: " obj ", pressed " pressed ", status " status)
					; (print "canvas-origin: " (canvas-origin the-cnv))

		  (tests:summarize-items run-id test-id test-name #f))
	      (tests:summarize-test run-id test-id)  ;; don't force - just update if no
	      (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
	    (mutex-unlock! m)
	    (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)))))))
		(exit 4))))
        )))

(define (launch:cache-config)
  ;; if we have a linktree and -runtests and -target and the directory exists dump the config
  ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
  (if (and *configdat* 
	   (or (args:get-arg "-run")
	       (args:get-arg "-runtests")

;;     sets; *configdat*    (megatest.config info)
;;           *runconfigdat* (runconfigs.config info)
;;           *configstatus* (status of the read data)
;;
(define (launch:setup #!key (force-reread #f) (areapath #f))
  (mutex-lock! *launch-setup-mutex*)
  (if (and *toppath*
	   (eq? *configstatus* 'fulldata)) ;; got it all
	   (eq? *configstatus* 'fulldata) (not force-reread)) ;; got it all
      (begin
	(debug:print 2 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata")
	(mutex-unlock! *launch-setup-mutex*)
	*toppath*)
      (let ((res (launch:setup-body force-reread: force-reread areapath: areapath)))
	(mutex-unlock! *launch-setup-mutex*)
	res)))

    (cons mtcachef rccachef)))

(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?))
      (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting.  We do not have *configdat*.  Bootstrapping problem here.
	     (toppath  (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
	     (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))
	     (mtcachef   (car cachefiles)) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-"  megatest-version "-" megatest-fossil-hash)))
	     (rccachef   (cdr cachefiles)) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-"  megatest-version "-" megatest-fossil-hash)))
	     ) ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?)))))
	(set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
        ;;(BB> "launch:setup-body -- cachefiles="cachefiles)
	(cond
	 ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
	 ((and mtcachef (common:file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME") use-cache)
	  (set! *configdat*    (configf:read-alist mtcachef))
	 ((and (not force-reread) mtcachef (common:file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME") use-cache)
          ;;(BB> "launch:setup-body -- cond branch 1 - use-cache")
          (set! *configdat*    (configf:read-alist mtcachef))
          ;;(BB> "launch:setup-body -- 1 set! *configdat*="*configdat*)
	  (set! *runconfigdat* (configf:read-alist rccachef))
	  (set! *configinfo*   (list *configdat*  (get-environment-variable "MT_RUN_AREA_HOME")))
	  (set! *configstatus* 'fulldata)
	  (set! *toppath*      (get-environment-variable "MT_RUN_AREA_HOME"))
	  *toppath*)
	 ;; we have all the info needed to fully process runconfigs and megatest.config
	 (mtcachef              
	 ((and (not force-reread) mtcachef) ;; BB- why are we doing this without asking if caching is desired?
          ;;(BB> "launch:setup-body -- cond branch 2")
	  (let* ((first-pass    (find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect
				 mtconfig
				 environ-patt: "env-override"
				 given-toppath: toppath
				 pathenvvar: "MT_RUN_AREA_HOME"))
		 (first-rundat  (let ((toppath (if toppath 
						   toppath
						   (car first-pass))))
				  (read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now.
				   (conc (if (string? toppath)
					     toppath
					     (get-environment-variable "MT_RUN_AREA_HOME"))
					 "/runconfigs.config")
				   *runconfigdat* #t 
				   sections: sections))))
	    (set! *runconfigdat* first-rundat)
	    (if first-pass  ;; 
		(begin
                  ;;(BB> "launch:setup-body -- \"first-pass\"=first-pass")
		  (set! *configdat*  (car first-pass))
                  ;;(BB> "launch:setup-body -- 2 set! *configdat*="*configdat*)
		  (set! *configinfo* first-pass)
		  (set! *toppath*    (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
		  (set! toppath      *toppath*)
		  (if (not *toppath*)
		      (begin
			(debug:print-error 0 *default-log-port* "you are not in a megatest area!")
			(exit 1)))

                         (mtcachef     (car cachefiles))
                         (rccachef     (cdr cachefiles)))
		    (if rccachef (configf:write-alist runconfigdat rccachef))
		    (set! *runconfigdat* runconfigdat)
		    (if mtcachef (configf:write-alist *configdat* mtcachef))
		    (if (and rccachef mtcachef) (set! *configstatus* 'fulldata))))
		;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table
		(set! *configdat* (make-hash-table))
		(begin (set! *configdat* (make-hash-table))
                       ;;(BB> "launch:setup-body -- 3 set! *configdat*="*configdat*)
                       )
		)))
	 ;; else read what you can and set the flag accordingly
	 (else
          ;;(BB> "launch:setup-body -- cond branch 3 - else")
	  (let* ((cfgdat   (find-and-read-config 
			    (or (args:get-arg "-config") "megatest.config")
			    environ-patt: "env-override"
			    given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
			    pathenvvar: "MT_RUN_AREA_HOME")))
	    (if cfgdat

            (if (and cfgdat (list? cfgdat) (> (length cfgdat) 0) (hash-table? (car cfgdat)))
		(let* ((toppath  (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
		       (rdat     (read-config (conc toppath  ;; convert this to use runconfig:read!
						    "/runconfigs.config") *runconfigdat* #t sections: sections)))
		  (set! *configinfo*   cfgdat)
		  (set! *configdat*    (car cfgdat))
		  (set! *runconfigdat* rdat)
		  (set! *toppath*      toppath)

  -test-paths             : get the test paths matching target, runname, item and test
                            patterns.
  -list-disks             : list the disks available for storing runs
  -list-targets           : list the targets in runconfigs.config
  -list-db-targets        : list the target combinations used in the db
  -show-config            : dump the internal representation of the megatest.config file
  -show-runconfig         : dump the internal representation of the runconfigs.config file
  -dumpmode MODE          : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc.
  -dumpmode MODE          : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
  -show-cmdinfo           : dump the command info for a test (run in test environment)
  -section sectionName
  -var varName            : for config and runconfig lookup value for sectionName varName
  -since N                : get list of runs changed since time N (Unix seconds)
  -fields fieldspec       : fields to include in json dump; runs:id,runame+tests:testname+steps
  -sort fieldname         : in -list-runs sort tests by this field

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

    
;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
;; where (launch:setup) returns #f?
;;
(if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server
    (handle-exceptions
	exn
	(begin
	  (print "ERROR: Failed to switch to log output. " ((conition-property-accessor 'exn 'message) exn))
	  )
      (let* ((tl   (or (args:get-arg "-log")(launch:setup)))   ;; run launch:setup if -server
      (let* ((tl   (or (args:get-arg "-log")(launch:setup)))   ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
	     (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
		       (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
	     (oup  (open-logfile logf)))
	(if (not (args:get-arg "-log"))
	    (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
	(debug:print-info 0 *default-log-port* "Sending log output to " logf)
	(set! *default-log-port* oup))))

Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))

;; args and pkt key specs
;;
(define *arg-keys*
  '(
  '(("-area"       . G) ;; maps to group
    ("-target"     . t)
    ("-run-name"   . n)
    ("-state"      . e)
    ("-status"     . s)
    ("-contour"    . c)
    ("-test-patt"  . p)  ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
    ("-mode-patt"  . o)
    ("-tag-expr"   . x)
    ("-area"            . G) ;; maps to group
    ("-contour"         . c)
    ("-append-config"   . d)
    ("-state"           . e)
    ("-item-patt"       . i)
    ("-sync-to"         . k)
    ("-run-name"        . n)
    ("-mode-patt"       . o)
    ("-test-patt"       . p)  ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
    ("-status"          . s)
    ("-target"          . t)
    ("-tag-expr"        . x)
    ("-item-patt"  . i)
    ("-sync-to"    . k)
    ("-append-config" . d)
    ;; misc
    ("-start-dir"  . S)
    ("-msg"        . M)
    ("-set-vars"   . v)
    ("-debug"      . #f)  ;; for *verbosity* > 2
    ("-load"       . #f)  ;; load and exectute a scheme file
    ("-log"        . #f)
    ("-debug"           . #f)  ;; for *verbosity* > 2
    ("-load"            . #f)  ;; load and exectute a scheme file
    ("-log"             . #f)
    ("-msg"             . M)
    ("-start-dir"       . S)
    ("-set-vars"        . v)
    ))
(define *switch-keys*
  '(
  '(("-h"          . #f)
    ("-help"       . #f)
    ("--help"      . #f)
    ("-manual"     . #f)
    ("-version"    . #f)
    ;; misc
    ("-repl"       . #f)
    ("-immediate"  . I)
    ("-preclean"   . r)
    ("-rerun-all"  . u)
    ("-h"               . #f)
    ("-help"            . #f)
    ("--help"           . #f)
    ("-manual"          . #f)
    ("-version"         . #f)
    ;; misc	        
    ("-repl"            . #f)
    ("-immediate"       . I)
    ("-preclean"        . r)
    ("-rerun-all"       . u)
    ("-prepend-contour" . w)
    ))

;; alist to map actions to old megatest commands
(define *action-keys*
  '((run         . "-run")
    (sync        . "")
    (archive     . "-archive")

				       (print " message: " ((condition-property-accessor 'exn 'message) exn))
				       runkey)
				   ((hash-table-ref *target-mappers* xlatr-key)
				    runkey new-runname area area-path reason contour mode-patt)))
			       (begin
				 (print "ERROR: Failed to find named target translator " xlatr-key ", using original target.")
				 runkey)))
			 runkey)))
			 runkey))
	 (actual-action  (if action
			     (if (equal? action "sync-prepend")
				 "sync"
				 action)
			     "run"))) ;; this has gotten a bit ugly. Need a function to handle actions processing.
    ;; some hacks to remove switches not needed in certain cases
    (case (string->symbol (or action "run"))
      ((sync)
      ((sync sync-prepend)
       (set! new-target #f)
       (set! runame     #f)))
    (print "area-path: " area-path " area-xlatr: " area-xlatr " orig-target: " runkey " new-target: " new-target)
    (let-values (((uuid pkt)
		  (command-line->pkt
		   (if action action "run")
		   actual-action
		   (append 
		    `(("-start-dir"  . ,area-path)
		      ("-msg"        . ,reason)
		      ("-contour"    . ,contour))
		    (if (good-val new-runname) `(("-run-name"      . ,new-runname)) '())
		    (if (good-val new-target)  `(("-target"        . ,new-target))  '())
		    (if (good-val mode-patt)   `(("-mode-patt"     . ,mode-patt))   '())
		    (if (good-val tag-expr)    `(("-tag-expr"      . ,tag-expr))    '())
		    (if (good-val dbdest)      `(("-sync-to"       . ,dbdest))      '())
		    (if (good-val append-conf) `(("-append-config" . ,append-conf)) '())
		    (if (equal? action "sync-prepend") '(("-prepend-contour" . " "))   '())
		    (if (not (or mode-patt tag-expr))
			`(("-testpatt"  . "%"))
			'())
		    (if (or (not action)
			    (equal? action "run"))
			`(("-preclean"  . " ")
			  ("-rerun-all" . " "))      ;; if run we *always* want preclean set, use single space as placeholder

                                 (areas    (val-alist->areas val-alist))
				 ;; (action   (alist-ref 'action   val-alist))
				 (cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "X"))
				 (runname  std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))))
			    ;; (print "last-run: " last-run " need-run: " need-run)
			    ;; (if need-run
			    (case (string->symbol action)
			      ((sync)
			      ((sync sync-prepend)
			       (if (common:extended-cron crontab #f last-sync)
				   (push-run-spec torun contour runkey
						  `((message . ,(conc ruletype ":sync-" cron-safe-string))
						    (action  . ,action)
						    (dbdest  . ,(alist-ref 'dbdest val-alist))
						    (append  . ,(alist-ref 'appendconf val-alist))))))
			      ((run)

                                   (dbdest  (alist-ref 'dbdest  runkeydat))
                                   (append  (alist-ref 'append  runkeydat))
                                   (target  (or (alist-ref 'target  runkeydat) runkey))) ;; override with target if forced
                               (print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target)
                               (if (case (or (and action (string->symbol action)) 'noaction)  ;; ensure we have the needed data to run this action
                                     ((noaction) #f)
                                     ((run)      (and runname reason))
                                     ((sync)     (and reason dbdest))
				 ((sync sync-prepend)     (and reason dbdest))
                                     (else       #f))
                                   ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt
                                   (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append runtrans) 
                                   (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area  " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest)
                                   ))
                             (print "NOTE: skipping " runkeydat " for area, not in " areas)))
		       all-areas))

# 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=/mfs/matt/.sysmaint/local.config
quick:scheduled:sync   cron=  0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
all:scheduled:sync          cron=  0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
quick:scheduled:sync        cron=  0/5 * * * *;dbdest=pgdb;appendconf=/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

	  exn
	  (let ((call-chain (get-call-chain))
		(msg        ((condition-property-accessor 'exn 'message) exn)))
	    (if (< count 5)
		(begin ;; this call is colliding, do some crude stuff to fix it.
		  (debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count)
		  (launch:setup force-reread: #t)
		  (fatal-loop (+ count 1)))
		  (fatal-loop (+ count 1))) 
		(begin
		  (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count " times. Message: " msg)
		  (debug:print 0 *default-log-port* "Call chain:")
		  (with-output-to-port *default-log-port*

		    (lambda ()(pp call-chain)))
                    (lambda ()
                      (print "*configdat* is >>"*configdat*"<<")
                      (pp *configdat*)
                      (pp call-chain)))
                  
		  (exit 1))))
          ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5")
          (when (or (not *configdat*) (not (hash-table? *configdat*)))
              (debug:print 0 *default-log-port* "WARNING: *configdat* was inaccessible! This should never happen.  Brute force reread.")
              ;;(BB> "ERROR: *configdat* was inaccessible! This should never happen.  Brute force reread.")
              (thread-sleep! 2) ;; assuming nfs lag.
              (launch:setup force-reread: #t))
          (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block.
    ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2")
    ;; Lets use this as an opportunity to put MT_RUNNAME in the environment
    (let ((runname  (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
      (if runname
	  (setenv "MT_RUNNAME" runname)
	  (debug:print-error 0 *default-log-port* "no value for runname for id " run-id)))