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

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

    (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 ((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! "dot" dot)
       (s:set! "type"  type)
       (s:set! "bp"  bp)







       (s:set! "rel" rel)))))

;;======================================================================
;; 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"))))
         
         (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")

                       (if (and (s:get "type") (not (equal? (s:get "type") "all")))
                              (s:get "type")
                              "all")))

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

          (pattern  (pgdb:mk-pattern dot type bp rel)) 	 



	; (targets     (pgdb:get-targets-of-type 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)
			  
         (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"
          








        (map (lambda (x)










            	(s:li (s:a 'href (conc "#" x) x)))









	  *process*))
       (map (lambda (x)
        























       (s:div 'id  x 'class "tab-content"
      (s:div 'class "col_11"
	   (s:fieldset    "Area type and target filter"
	    (s:form
	     'action (conc "home.filter#" x) 'method "post"
	     (s:div 'class "col_12"
                        (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)))


					  *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: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 " pattern)



	      (let* ((a-keys (pgdb:ordered-data->a-keys ordered-data))
		   (b-keys (pgdb:ordered-data->b-keys ordered-data a-keys)))
















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



				     (s:td ""))))
			     a-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")

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

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

(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
  (let* ((keys    (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
	 (numkeys (length keys))
	 (target  (or (args:get-arg "-reqtarg")
		      (args:get-arg "-target")
		      (getenv "MT_TARGET")))
	 (tlist   (if target (string-split target "/" #t) '()))
	 (valid   (if target
		      (or (null? keys) ;; probably don't know our keys yet

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

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

(include "common_records.scm")

;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))

;; pathenvvar will set the named var to the path of the config
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname toppath: given-toppath))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo))
	 (set-fields (lambda (curr-section next-section ht path)
		       (let ((field-names (if ht (common:get-fields ht) '()))
			     (target      (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
			 (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
			 (if (not (null? field-names))(keys:target-set-args field-names target #f))))))
    (if toppath (change-directory toppath)) 
    (if (and toppath pathenvvar)(setenv pathenvvar toppath))
    (let ((configdat  (if configfile 
			  (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))

	   (list key targ))
	 keys targtweaked)))

;;======================================================================
;; config file related routines
;;======================================================================

(define keys:config-get-fields common:get-fields)

;; (include "common.scm")
;; (include "megatest-version.scm")

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

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

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

(define help (conc "
mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017

Usage: mtutil action [options]
  -h                         : this help
  -manual                    : show the Megatest user manual
  -version                   : print megatest version (currently " megatest-version ")
			     
Actions:		     
   run                       : initiate runs
   remove                    : remove runs
   rerun                     : register action for processing
   set-ss                    : set state/status
   archive                   : compress and move test data to archive disk
   kill                      : stop tests or entire runs
   db                        : database utilities
   areas, contours, setup    : show areas, contours or setup section from megatest.config

Contour actions:
   process                   : runs import, rungen and dispatch 
			     
Selectors 		     
  -immediate                 : apply this action immediately, default is to queue up actions
  -area areapatt1,area2...   : apply this action only to the specified areas
  -target key1/key2/...      : run for key1, key2, etc.
  -test-patt p1/p2,p3/...    : % is wildcard
  -run-name                  : required, name for this particular test run
  -contour contourname       : run all targets for contourname, requires -run-name, -target
  -state-status c/p,c/f      : Specify a list of state and status patterns
  -tag-expr tag1,tag2%,..    : select tests with tags matching expression
  -mode-patt key             : load testpatt from <key> in runconfigs instead of default TESTPATT
                               if -testpatt and -tagexpr are not specified
  -new state/status          : specify new state/status for set-ss
			     
Misc 			     
  -start-dir path            : switch to this directory before running mtutil
  -set-vars V1=1,V2=2        : Add environment variables to a run NB// these are
                                   overwritten by values set in config files.
  -log logfile               : send stdout and stderr to logfile
  -repl                      : start a repl (useful for extending megatest)
  -load file.scm             : load and run file.scm
  -debug N|N,M,O...          : enable debug messages 0-N or N and M and O ...
			     
Utility			     
 db pgschema                 : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\"

Examples:

# Start a megatest run in the area \"mytests\"
mtutil run -area mytests -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick

# Start a contour
mtutil run -contour quick -target v1.63/aa3e 

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



    ;; misc



    ("-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)
    ("-prepend-contour" . w)
    ))

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

;;
(if (and (not (null? remargs))
	 (not (or
	       (args:get-arg "-runstep")
	       (args:get-arg "-envcap")
	       (args:get-arg "-envdelta")
	       (member *action* '("db"))   ;; very loose checks on db.
	       (equal? *action* "show")    ;; just keep going if list
	       )))
    (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))

(if (or (args:any? "-h" "help" "-help" "--help")
	(member *action* '("-h" "-help" "--help" "help")))
    (begin
      (print help)

	 (toppath  (configf:lookup mtconf "dyndat" "toppath"))
	 (pdbpath  (or (configf:lookup mtconf "setup"  "pdbpath") pktsdir)))
    (if (not (and  pktsdir toppath pdbpath))
	(begin
	  (print "ERROR: settings are missing in your megatest.config for area management.")
	  (print "  you need to have pktsdir in the [setup] section."))
	(let* ((pdb  (open-queue-db pdbpath "pkts.db"
				    schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))
	       (res  (proc pktsdirs pktsdir pdb)))
	  (dbi:close pdb)
	  res
	  ))))

(define (load-pkts-to-db mtconf)
  (with-queue-db
   mtconf
   (lambda (pktsdirs pktsdir pdb)
     (for-each
      (lambda (pktsdir) ;; look at all
	(if (and (file-exists? pktsdir)
		 (directory? pktsdir)
		 (file-read-access? pktsdir))
	    (let ((pkts (glob (conc pktsdir "/*.pkt"))))
	      (for-each
	       (lambda (pkt)
		 (let* ((uuid    (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
			(exists  (lookup-by-uuid pdb uuid #f)))
		   (if (not exists)
		       (let* ((pktdat (string-intersperse
				       (with-input-from-file pkt read-lines)
				       "\n"))
			      (apkt   (pkt->alist pktdat))
			      (ptype  (alist-ref 'T apkt))
			      (parent (alist-ref 'P apkt)))
			 (add-to-queue pdb pktdat uuid (or ptype 'cmd) parent 0)
			 (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
		       (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
		       )))
	       pkts))))
      (string-split pktsdirs)))))

(define (get-pkt-alists pkts)

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

(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(if *action*
    (case (string->symbol *action*)
      ((run remove rerun set-ss archive kill list)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
	      (pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f))
	      (adjargs   (hash-table-copy args:arg-hash)))
	 ;; (for-each
	 ;;  (lambda (key)

			 (load-pkts-to-db mtconf)
			 (generate-run-pkts mtconf toppath)
			 (load-pkts-to-db mtconf)
			 (dispatch-commands mtconf toppath)))
	   ((import)   (load-pkts-to-db mtconf)) ;; import pkts
	   ((rungen)   (generate-run-pkts mtconf toppath))
	   ((dispatch) (dispatch-commands mtconf toppath)))))
      ;; misc
      ((show)
       (if (> (length remargs) 0)
	   (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
		  (mtconf    (car mtconfdat))
		  (sect-dat (configf:get-section mtconf (car remargs))))
	     (if sect-dat
		 (for-each
		  (lambda (entry)
		    (if (> (length entry) 1)
			(print (car entry) "   " (cadr entry))
			(print (car entry))))
		  sect-dat)
		 (print "No section \"" (car remargs) "\" found")))
	   (print "ERROR: list requires section parameter; areas, setup or contours")))
      ((gendot)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat)))
	 (with-queue-db
	  mtconf
	  (lambda (pktsdirs pktsdir conn)
	    (make-report "out.dot" conn '())))))
      ((db)
       (if (null? remargs)
	   (print "ERROR: missing sub command for db command")
	   (let ((subcmd (car remargs)))
	     (case (string->symbol subcmd)
	       ((pgschema)
		(let* ((install-home (common:get-install-area))

      ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
      
      (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;;  [homedir] [filename] [nlines])
      (current-input-port (make-readline-port "mtutil> "))
      (if (args:get-arg "-repl")
	  (repl)
	  (load (args:get-arg "-load")))))

#|
(define mtconf (car (simple-setup #f)))
(define dat (with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
|#

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

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

# tip will be replaced with hashkey?

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

[/.*/]

# [v1.63/tip/dev]
# file:   files changes since last run trigger new run
# script: script is called with unix seconds as last parameter (other parameters are preserved)
#
# contour:sensetype:action params            data
# commented out for debug
# quick:file:run             runtrans=auto;         glob=/home/matt/data/megatest/*.scm
# snazy:file:run             runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm
short:file:run             runtrans=short;        glob=/home/matt/data/megatest/*.scm

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

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

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

      (let* ((test-record (hash-table-ref test-records hed))
	     (test-name   (tests:testqueue-get-testname test-record))
	     (tconfig     (tests:testqueue-get-testconfig test-record))
	     (jobgroup    (config-lookup tconfig "test_meta" "jobgroup"))
	     (testmode    (let ((m (config-lookup tconfig "requirements" "mode")))
			    (if m (map string->symbol (string-split m)) '(normal))))
	     (itemmaps    (tests:get-itemmaps tconfig)) ;;  (configf:lookup tconfig "requirements" "itemmap"))
	     (waitons     (tests:just-get-waitons test-name test-records)) ;; (tests:testqueue-get-waitons    test-record))
	     (priority    (tests:testqueue-get-priority   test-record))
	     (itemdat     (tests:testqueue-get-itemdat    test-record)) ;; itemdat can be a string, list or #f
	     (items       (tests:testqueue-get-items      test-record))
	     (item-path   (item-list->path itemdat))
	     (tfullname   (db:test-make-full-name test-name item-path))
	     (newtal      (append tal (list hed)))
	     (regfull     (>= (length reg) reglen))

       lst))

;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
;;
(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry)
  ;; All these vars might be referenced by the testconfig file reader
  (let* ((test-name    (tests:testqueue-get-testname   test-record))
	 (test-waitons (tests:just-get-waitons test-name all-tests-registry)) ;; (tests:testqueue-get-waitons    test-record))
	 (test-conf    (tests:testqueue-get-testconfig test-record))
	 (itemdat      (tests:testqueue-get-itemdat    test-record))
	 (test-path    (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
	 (force        (hash-table-ref/default flags "-force" #f))
	 (rerun        (hash-table-ref/default flags "-rerun" #f))
	 (keepgoing    (hash-table-ref/default flags "-keepgoing" #f))
	 (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x")))

      'have-procedure)
     ((or (list? items)(list? itemstable)) ;; calc now
      (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n"
			"    items: " items " itemstable: " itemstable)
      (items:get-items-from-config tconfig))
     (else #f))))                           ;; not iterated


;; returns waitons waitors tconfigdat
;;
;;  firm-require forces that the test be referred to in all-tests-registry
;;
(define (tests:get-waitons test-name all-tests-registry #!key (in-tconfig #f)(firm-require #t))
  (let* ((config   (or in-tconfig (tests:get-testconfig test-name #f all-tests-registry 'return-procs)))
	 (extras   (configf:get-section *configdat* "waitons"))
	 (ewaits   (if extras (alist-ref test-name extras string=?) #f))
	 (ewlst    (if (and ewaits (not (null? ewaits)))
		       (string-split (car ewaits))
		       '()))
         (ewadd    (if (null? ewlst)
                       #t
                       (equal? (car ewlst) "+"))) ;; signal for add
         (ewaitlst (if (null? ewlst)
                       ewlst
                       (if ewadd
                           (cdr ewlst)
                           ewlst))))
     (let ((instr (if config 
		      (config-lookup config "requirements" "waiton")
		      (if firm-require ;; begin ;; No config means this is a non-existant test
			(debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"")
			;; (exit 1)
                        )))
	   (instr2 (if config
		       (config-lookup config "requirements" "waitor")
		       "")))
       (debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2)
       (let ((newwaitons
	      (string-split (cond
			     ((procedure? instr) ;; here 

			     ((string? instr2)     instr2)
			     (else 
			      ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " test-name)
			      "")))))
	 (values
	  ;; the waitons
	  (filter (lambda (x)
		    (if (or (not firm-require)
                            (hash-table-ref/default all-tests-registry x #f))
			#t
			(begin
			  (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x)
			  #f)))
		  (if ewadd ;; area we adding or replacing the waitons
                      (append newwaitons ewaitlst)
                      ewaitlst))
	  (filter (lambda (x)
		    (if (or (not firm-require)
                            (hash-table-ref/default all-tests-registry x #f))
			#t
			(begin
			  (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waitor testname " x)
			  #f)))
		  newwaitors)
	  config)))))

;; seems like often we just want the waitons. Maybe time to get rid of the waitors concept?
;;
(define (tests:just-get-waitons test-name tests-registry #!key (in-tconfig #f)(firm-require #t))
  (let-values (((waitons waitors tconfig)
                (tests:get-waitons test-name tests-registry in-tconfig: in-tconfig firm-require: firm-require)))
    waitons))
					     
;; given waiting-test that is waiting on waiton-test extend test-patt appropriately
;;
;;  genlib/testconfig               sim/testconfig
;;  genlib/sch                      sim/sch/cell1
;;
;;  [requirements]                  [requirements]

				  (let ((tmp (any->number priority)))
				    (if tmp tmp (begin (debug:print-error 0 *default-log-port* "bad priority value " priority ", using 0") 0)))
				  0)))
	     (all-tests      (hash-table-keys test-records))
	     (all-waited-on  (let loop ((hed (car all-tests))
					(tal (cdr all-tests))
					(res '()))
			       (let* (;; (trec    (hash-table-ref test-records hed))
				      (waitons (tests:just-get-waitons hed test-records firm-require: #f))) ;; (or (tests:testqueue-get-waitons trec) '())))
                                 (if (null? tal)
				     (append res waitons)
				     (loop (car tal)(cdr tal)(append res waitons))))))
	     (sort-fn1 
	      (lambda (a b)
		(let* ((a-record   (hash-table-ref test-records a))
		       (b-record   (hash-table-ref test-records b))
		       (a-waitons  (tests:just-get-waitons a test-records firm-require: #f)) ;; (or (tests:testqueue-get-waitons a-record) '()))
		       (b-waitons  (tests:just-get-waitons b test-records firm-require: #f)) ;; (or (tests:testqueue-get-waitons b-record) '()))
		       (a-config   (tests:testqueue-get-testconfig  a-record))
		       (b-config   (tests:testqueue-get-testconfig  b-record))
		       (a-raw-pri  (config-lookup a-config "requirements" "priority"))
		       (b-raw-pri  (config-lookup b-config "requirements" "priority"))
		       (a-priority (mungepriority a-raw-pri))
		       (b-priority (mungepriority b-raw-pri)))
		  (tests:testqueue-set-priority! a-record a-priority)

	  (temp-port     (open-output-file* fd)))
      ;; (format temp-port "This file is ~A.~%" temp-path)
      (format temp-port "digraph tests {\n")
      (format temp-port "  size=4,8\n")
      ;; (format temp-port "   splines=none\n")
      (for-each
       (lambda (testname)
	 (let* (;; (testrec (hash-table-ref test-records testname))
		(waitons (tests:just-get-waitons testname test-records firm-require: #f))) ;; (or (tests:testqueue-get-waitons testrec) '())))
	   (for-each
	    (lambda (waiton)
	      (format temp-port (conc "   " waiton " -> " testname " [splines=ortho]\n")))
	    waitons)))
       all-testnames)
      (format temp-port "}\n")
      (close-output-port temp-port)

	'()
	(let loop ((hed (car all-testnames))
		   (tal (cdr all-testnames))
		   (res (list "digraph tests {"
			      (conc " size=\"" (or sizex 11) "," (or sizey 11) "\";")
			      " ratio=0.95;"
			      )))
	  (let* (;; (testrec (hash-table-ref test-records hed))
		 (waitons (tests:just-get-waitons hed test-records firm-require: #f)) ;; (or (tests:testqueue-get-waitons testrec) '()))
		 (newres  (append res
				  (if (null? waitons)
				      (list (conc "   \"" hed "\" [shape=box];"))
				      (map (lambda (waiton)
					     (conc "   \"" waiton "\" -> \"" hed "\" [shape=box];"))
					   waitons)
				      ))))

  (let ((runnables '()))
    (for-each
     (lambda (testkeyname)
       (let* ((test-record (hash-table-ref testrecordshash testkeyname))
	      (test-name   (tests:testqueue-get-testname  test-record))
	      (itemdat     (tests:testqueue-get-itemdat   test-record))
	      (item-path   (tests:testqueue-get-item_path test-record))
	      (waitons     (tests:just-get-waitons test-name testrecordshash)) ;; (tests:testqueue-get-waitons   test-record))
	      (keep-test   #t)
	      (test-id     (rmt:get-test-id run-id test-name item-path))
	      (tdat        (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
	 (if tdat
	     (begin
	       ;; Look at the test state and status
	       (if (or (and (member (db:test-get-status tdat) 

(define (tests:get-full-data test-names test-records required-tests all-tests-registry)
  (if (not (null? test-names))
      (let loop ((hed (car test-names))
		 (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	(debug:print-info 4 *default-log-port* "hed=" hed " at top of loop")
        ;; don't know item-path at this time, let the testconfig get the top level testconfig
	(let* ((config  (tests:get-testconfig hed #f all-tests-registry 'return-procs))
	       (waitons (let-values (((waitons waitors tconfigdat)
                                      (tests:get-waitons hed all-tests-registry)))
                          waitons)))
                        ;; (let ((instr (if config 
			;; 		 (config-lookup config "requirements" "waiton")
			;; 		 (begin ;; No config means this is a non-existant test
			;; 		   (debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
			;; 		     ""))))
			;;   (debug:print-info 8 *default-log-port* "waitons string is " instr)
			;;   (string-split (cond
			;; 		 ((procedure? instr)
			;; 		  (let ((res (instr)))
			;; 		    (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " hed)
			;; 		    res))
			;; 		 ((string? instr)     instr)
			;; 		 (else 
			;; 		  ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " hed)
			;; 		  ""))))))
	  (if (not config) ;; this is a non-existant test called in a waiton. 
	      (if (null? tal)
		  test-records
		  (loop (car tal)(cdr tal)))
	      (begin
		(debug:print-info 8 *default-log-port* "waitons: " waitons)
		;; check for hed in waitons => this would be circular, remove it and issue an