Megatest

(define *configinfo* #f)
(define *configdat*  #f)
(define *toppath*    #f)
(define *already-seen-runconfig-info* #f)
(define *waiting-queue* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum*     0) ;; when running track calls to run-tests or similar

(define *verbosity*   1)

(define-inline (get-with-default val default)
  (let ((val (args:get-arg val)))
    (if val val default)))

(define-inline (assoc/default key lst . default)
  (let ((res (assoc key lst)))
    (if res (cadr res)(if (null? default) #f (car default)))))

;;======================================================================
;; Misc utils
;;======================================================================

(define-inline (debug:print n . params)
  (if (<= n *verbosity*)
      (apply print params)))

(define (get-df path)
  (let* ((df-results (cmd-run->list (conc "df " path)))
	 (space-rx   (regexp "([0-9]+)\\s+([0-9]+)%"))
	 (freespc    #f))
    ;; (write df-results)
    (for-each (lambda (l)

	       (section-rx ( x section-name ) (loop (read-line inp) section-name))
	       (key-sys-pr ( x key cmd      ) (let ((alist (hash-table-ref/default res curr-section-name '()))
						    (val   (let* ((cmdres  (cmd-run->list cmd))
								  (status  (cadr cmdres))
								  (res     (car  cmdres)))
							     (if (not (eq? status 0))
								 (begin
								   (print "ERROR: problem with " inl ", return code not 0")
								   (debug:print 0 "ERROR: problem with " inl ", return code " status)
								   (exit 1)))
							     (if (null? res)
								 ""
								 (string-intersperse res " ")))))
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key val))
								 ;; (append alist (list (list key val))))
						(loop (read-line inp) curr-section-name)))
	       (key-val-pr ( x key val      ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key val))
								 ;; (append alist (list (list key val))))
						(loop (read-line inp) curr-section-name)))
	       (else (print "ERROR: problem parsing " path ",\n   \"" inl "\"")
	       (else (debug:print 0 "ERROR: problem parsing " path ",\n   \"" inl "\"")
		     (loop (read-line inp) curr-section-name))))))))
  
(define (find-and-read-config fname)
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo)))

							    "runname") #f))
	 ;(teststeps     (if testdat (db:get-steps-for-test db test-id) #f))
	 (logfile       "/this/dir/better/not/exist")
	 (rundir        logfile)
	 (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
	 (viewlog    (lambda (x)
		       (if (file-exists? logfile)
			   (system (conc "firefox " logfile "&"))
			   ;(system (conc "firefox " logfile "&"))
			   (iup:send-url logfile)
			   (message-window (conc "File " logfile " not found")))))
	 (xterm      (lambda (x)
		       (if (directory-exists? rundir)
			   (let ((shell (if (get-environment-variable "SHELL") 
					    (conc "-e " (get-environment-variable "SHELL"))
					    "")))
			     (system (conc "cd " rundir 

(use canvas-draw)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)

(import (prefix sqlite3 sqlite3:))

(include "common.scm")
(include "margs.scm")
(include "keys.scm")
(include "items.scm")
(include "db.scm")
(include "configf.scm")
(include "process.scm")
(include "launch.scm")

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-rows"
			"-run"
			"-test"
			"-debug"
			) 
		 (list  "-h"
			"-v"
			"-q"
		       )
		 args:arg-hash
		 0))

(if (args:get-arg "-h")
    (begin
      (print help)

(define max-test-num 0)
(define *keys*   (get-keys   *db*))
(define dbkeys   (map (lambda (x)(vector-ref x 0))
		      (append *keys* (list (vector "runname" "blah")))))
(define *header*       #f)
(define *allruns*     '())
(define *buttondat*    (make-hash-table)) ;; <run-id color text test run-key>
(define *alltestnames* (make-hash-table)) ;; build a minimalized list of test names
(define *alltestnamelst* '())
(define *searchpatts*  (make-hash-table))
(define *num-runs*      10)
(define *num-tests*     15)
(define *start-run-offset*  0)
(define *start-test-offset* 0)
(define *examine-test-dat* (make-hash-table))
(define *exit-started* #f)

(define *verbosity* (cond
		     ((args:get-arg "-debug")(string->number (args:get-arg "-debug")))
		     ((args:get-arg "-v")    2)
		     ((args:get-arg "-q")    0)
		     (else                   1)))

(define uidat #f)
;; (megatest-dashboard)

;(define img1 (iup:image/palette 16 16 (u8vector->blob (u8vector
;				   1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 
;				   1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 
;				   1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 
;				   1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 
;				   1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 
;				   1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 
;				   1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 
;				   1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 
;				   2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 
;				   2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 
;				   2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 
;				   2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 
;				   2 2 2 0 2 0 2 0 2 2 0 2 2 2 0 0 
;				   2 2 2 0 2 0 0 2 0 0 2 0 2 0 2 2 
;				   2 2 2 0 2 0 2 2 0 2 2 0 2 2 2 2 
;				   2 2 2 0 2 0 2 2 0 2 2 0 2 2 0 0 
;				   2 2 2 0 2 0 2 2 0 2 2 0 2 0 2 1))))
;
;(define img2 (iup:image/palette 16 16 (u8vector->blob (u8vector
;				   2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 
;				   2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 
;				   2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 
;				   1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 
;				   1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 
;				   1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 
;				   1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 
;				   1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 
;				   2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 
;				   2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 
;				   2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 
;				   2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 
;				   2 2 2 0 2 0 2 0 2 2 0 2 2 2 0 0 
;				   2 2 2 0 2 0 0 2 0 0 2 0 2 0 2 2 
;				   2 2 2 0 2 0 2 2 0 2 2 0 2 2 2 2 
;				   2 2 2 0 2 0 2 2 0 2 2 0 2 2 0 0 
;				   2 2 2 0 2 0 2 2 0 2 2 0 2 0 2 1))))
;
;(iup:handle-name-set! img1 "img1")
;(iup:attribute-set! img1 "0" "0 0 0")
;(iup:attribute-set! img1 "1" "BGCOLOR")
;(iup:attribute-set! img1 "2" "255 0 0")
;
;(iup:handle-name-set! img2 "img2")
;(iup:attribute-set! img2 "0" "0 0 0")
;(iup:attribute-set! img2 "1" "BGCOLOR")
;(iup:attribute-set! img2 "2" "255 0 0")

(define (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 
     (iup:label msg #:margin "40x40")))))

(define (iuplistbox-fill-list lb items . default)

		      (set! maxtests (length tests)))
		  (set! result (cons (vector run tests key-vals) result))))
	      runs)
    (set! *header*  header)
    (set! *allruns* result)
    maxtests))

(define *collapsed* (make-hash-table))
; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj)

(define (toggle-hide lnum) ; fulltestname)
  (let* ((btn (vector-ref (vector-ref uidat 0) lnum))
	 (fulltestname (iup:attribute btn "TITLE"))
	 (parts        (string-split fulltestname "("))
	 (basetestname (if (null? parts) "" (car parts))))
    ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f))
    (if (hash-table-ref/default *collapsed* basetestname #f)
	(begin
	  ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")
	  (hash-table-delete! *collapsed* basetestname))
	(begin
	  ;(iup:attribute-set! btn "FGCOLOR" "0 192 192")
	  (hash-table-set! *collapsed* basetestname #t)))))
  
(define blank-line-rx (regexp "^\\s*$"))

(define (collapse-rows inlst)
  (let ((newlst (filter (lambda (x)
			  (let* ((tparts    (string-split x "("))
				 (basetname (if (null? tparts) x (car tparts))))
					;(print "x " x " tparts: " tparts " basetname: " basetname)
			    (cond
			     ((string-match blank-line-rx x) #f)
			     ((equal? x basetname) #t)
			     ((hash-table-ref/default *collapsed* basetname #f) 
					;(print "Removing " basetname " from items")
			      #f)
			     (else #t))))
			inlst)))
    ;; special sort to push the test(item) to after test
    (sort newlst (lambda (a b)
		   (let* ((partsa (string-split a "("))
			  (partsb (string-split b "("))
			  (lena   (length partsa))
			  (lenb   (length partsb)))
		     (if (or (and (eq? lena 1)(> lenb 1))
			     (and (eq? lenb 1)(> lena 1)))
			 (if (equal? (car partsa)(car partsb)) ;; same test
			     (> lenb lena)
			     #t)
			 #t))))))
			     
(define (update-labels uidat)
  (let* ((rown    0)
	 (lftcol  (vector-ref uidat 0))
	 (numcols (vector-length lftcol))
	 (maxn    (- numcols 1))
	 (allvals (make-vector numcols "")))
    (for-each (lambda (name)
		(if (<= rown maxn)
		    (let ((labl (vector-ref lftcol rown)))
		      (vector-set! allvals rown name)))
		(set! rown (+ 1 rown)))
	      *alltestnamelst*)
	      (if (> (length *alltestnamelst*) *start-test-offset*)
		  (drop *alltestnamelst* *start-test-offset*)
		  '()))
	;      (if (> (length *alltestnamelst*) *start-test-offset*)
	;	  (drop *alltestnamelst* *start-test-offset*)
	;	  '()))
    (let loop ((i 0))
      (let* ((lbl    (vector-ref lftcol i))
	     (oldval (iup:attribute lbl "TITLE"))
	     (newval (vector-ref allvals i)))
	(if (not (equal? oldval newval))
	    (iup:attribute-set! lbl "TITLE" newval))
	(iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0"))
	(if (< i maxn)
	    (loop (+ i 1)))))))

(define (get-color-for-state-status state status)
  (case (string->symbol state)
    ((COMPLETED)
     (if (equal? status "PASS")

  (let* ((runs        (if (> (length *allruns*) numruns)
			  (take-right *allruns* numruns)
			  (pad-list *allruns* numruns)))
	 (lftcol      (vector-ref uidat 0))
	 (tableheader (vector-ref uidat 1))
	 (table       (vector-ref uidat 2))
	 (coln        0))
    (set! *alltestnamelst* '())
    (update-labels uidat)
    (for-each 
     (lambda (popup)
       (let* ((test-id  (car popup))
    ;; create a concise list of test names
    (for-each (lambda (rundat)
		(if (vector? rundat)
		    (let* ((testdat   (vector-ref rundat 1))
	      (widgets  (hash-table-ref *examine-test-dat* popup))
	      (stepslbl (hash-table-ref/default widgets "Test Steps" #f)))
			   (testnames (map test:test-get-fullname testdat)))
	 (if stepslbl
	     (let* ((fmtstr  "~15a~8a~8a~20a")
		    (newtxt  (string-intersperse 
			      (append
			       (list 
				(format #f fmtstr "Stepname" "State" "Status" "Event Time")
				(format #f fmtstr "========" "=====" "======" "=========="))
			       (map (lambda (x)
		      (for-each (lambda (testname)
				      ;; take advantage of the \n on time->string
				      (format #f fmtstr
					      (db:step-get-stepname x)
				  (if (not (member testname *alltestnamelst*))
					      (db:step-get-state    x)
					      (db:step-get-status   x)
					      (time->string 
				      (begin
					       (seconds->local-time 
						(db:step-get-event_time x)))))
				    (db-get-test-steps-for-run *db* test-id)))
			     "\n")))
	       (iup:attribute-set! stepslbl "TITLE" newtxt)))))
     (hash-table-keys *examine-test-dat*))
    (set! *alltestnamelst* '())
					(set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
				testnames))))
	      runs)

    (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness
    (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*)
					 (drop *alltestnamelst* *start-test-offset*)
					 '())))
			     (append xl (make-list (- *num-tests* (length xl)) ""))))
    (update-labels uidat)
    (for-each
     (lambda (rundat)
       (if (not rundat) ;; handle padded runs
	   ;;           ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration
	   (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3)))
       (let* ((run      (vector-ref rundat 0))
	      (testsdat (vector-ref rundat 1))
	      (key-val-dat (vector-ref rundat 2))
	      (run-id   (db:get-value-by-header run *header* "id"))
	      (testnames (delete-duplicates (append *alltestnamelst* 
						    (map test:test-get-fullname testsdat)))) ;; (take (pad-list testsdat numtests) numtests))
	      (key-vals (append key-val-dat
				(list (let ((x (db:get-value-by-header run *header* "runname")))
					(if x x "")))))
	      (run-key  (string-intersperse key-vals "\n")))
	 ;; (run-ht  (hash-table-ref/default alldat run-key #f)))

	 ;; fill in the run header key values
	 (set! *alltestnamelst* testnames)
	 (let ((rown      0)
	       (headercol (vector-ref tableheader coln)))
	   (for-each (lambda (kval)
		       (let* ((labl      (vector-ref headercol rown)))
			 (if (not (equal? kval (iup:attribute labl "TITLE")))
			     (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval))
			 (set! rown (+ rown 1))))

		(if buttondat
		    (let* ((test       (let ((matching (filter 
							(lambda (x)(equal? (test:test-get-fullname x) testname))
							testsdat)))
					 (if (null? matching)
					     (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "")
					     (car matching))))
			   ;; (test       (if real-test real-test
			   (testname   (db:test-get-testname  test))
			   (itempath   (db:test-get-item-path test))
			   (testfullname (test:test-get-fullname test))
			   (teststatus (db:test-get-status   test))
			   (teststate  (db:test-get-state    test))
			   (teststart  (db:test-get-event_time test))
			   (runtime    (db:test-get-run_duration test))
			   (buttontxt  (if (equal? teststate "COMPLETED") teststatus teststate))
			   (button     (vector-ref columndat rown))
			   (color      (get-color-for-state-status teststate teststatus))
			   (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
			   (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
		;;       (if (and (equal? teststate "RUNNING")
		;; 	       (> (- (current-seconds) (+ teststart runtime)) 100)) ;; if test has been dead for more than 100 seconds, call it dead
			  
		      (if (not (equal? curr-color color))
			  (iup:attribute-set! button "BGCOLOR" color))
		      (if (not (equal? curr-title buttontxt))
			  (iup:attribute-set! button "TITLE"   buttontxt))
		      (vector-set! buttondat 0 run-id)
		      (vector-set! buttondat 1 color)
		      (vector-set! buttondat 2 buttontxt)
		      (vector-set! buttondat 3 test)
		      (vector-set! buttondat 4 run-key)
		      (vector-set! buttondat 4 run-key)))
		      (if (not (hash-table-ref/default *alltestnames* testfullname #f))
			  (begin
			    (hash-table-set! *alltestnames* testfullname #t)
			    (set! *alltestnamelst* (append *alltestnamelst* (list testfullname))))))
		    )
		(set! rown (+ rown 1))))
	    (let ((xl (if (> (length testnames) *start-test-offset*)
			  (drop testnames *start-test-offset*)
			  '()))) ;; testnames)))
	    *alltestnamelst*))
	      (append xl (make-list (- *num-tests* (length xl)) "")))))
	 (set! coln (+ coln 1))))
     runs)))

(define (mkstr . x)
  (string-intersperse (map conc x) ","))

(define (update-search x val)

    (let loop ((testnum  0)
	       (res      '()))
      (cond
       ((>= testnum ntests)
	;; now lftlst will be an hbox with the test keys and the test name labels
	(set! lftlst (append lftlst (list (apply iup:vbox (reverse res))))))
       (else
	(let ((labl  (iup:button "" #:flat "YES" #:size "100x15" #:fontsize "10")))
	(let ((labl  (iup:button "" 
				 #:flat "YES" 
				 ; #:image img1
				 ; #:impress img2
				 #:size "100x15"
				 #:fontsize "10"
				 #:action (lambda (obj)
					      (toggle-hide testnum))))) ;; (iup:attribute obj "TITLE"))))
	  (vector-set! lftcol testnum labl)
	  (loop (+ testnum 1)(cons labl res))))))
    ;; 
    (let loop ((runnum  0)
	       (keynum  0)
	       (keyvec  (make-vector nkeys))
	       (res    '()))
      (cond ;; nb// no else for this approach.
       ((>= runnum nruns) #f)
       ((>= keynum nkeys) 
	(vector-set! header runnum keyvec)
	(set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst))
	(loop (+ runnum 1) 0 (make-vector nkeys) '()))
       (else
	(let ((labl  (iup:label "" #:size "60x15" #:fontsize "10" ;; #:expand "HORIZONTAL"
	(let ((labl  (iup:label "" #:size "60x15" #:fontsize "10"))) ;; #:expand "HORIZONTAL"
				)))
	  (vector-set! keyvec keynum labl)
	  (loop runnum (+ keynum 1) keyvec (cons labl res))))))
    ;; By here the hdrlst contains a list of vboxes containing nkeys labels
    (let loop ((runnum  0)
	       (testnum 0)
	       (testvec  (make-vector ntests))
	       (res    '()))

				       ;; #:expand "HORIZONTAL"
				       #:fontsize "10" 
				       #:action (lambda (x)
						  (let* ((toolpath (car (argv)))
							 (buttndat (hash-table-ref *buttondat* button-key))
							 (test-id  (db:test-get-id (vector-ref buttndat 3)))
							 (cmd  (conc toolpath " -test " test-id "&")))
						    (print "Launching " cmd)
						    ;(print "Launching " cmd)
						    (system cmd))))))
	  (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) 
	  (vector-set! testvec testnum butn)
	  (loop runnum (+ testnum 1) testvec (cons butn res))))))
    ;; now assemble the hdrlst and bdylst and kick off the dialog
    (iup:show
     (iup:dialog 

	(get-environment-variable "DASHBOARDROWS" ))
    (begin
        (set! *num-tests* (string->number (or (args:get-arg "-rows")
					      (get-environment-variable "DASHBOARDROWS"))))
	(update-rundat "%" *num-runs* "%" "%"))
    (set! *num-tests* (min (max (update-rundat "%" *num-runs* "%" "%") 8) 20)))

(define uidat #f)
;; (megatest-dashboard)

(define (run-update mtx1)
  (let loop ((i 0))
    (thread-sleep! 0.05)
    (mutex-lock! mtx1)
    (update-buttons uidat *num-runs* *num-tests*)
    (mutex-unlock! mtx1)
    (iup:main-loop-flush)

;; WARNING: SQL injection risk
(define (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus)
  (for-each (lambda (testname)
	      (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE "
					(if currstate  (conc "state='" currstate "' AND ") "")
					(if currstatus (conc "status='" currstatus "' AND ") "")
					" testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
		;;(print "QRY: " qry)
		;;(debug:print 0 "QRY: " qry)
		(sqlite3:execute db qry newstate newstatus testname testname)))
	    testnames))
	      ;; "('" (string-intersperse tests "','") "')")

(define (db:delete-tests-in-state db run-id state)
  (sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run-id))

(define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment)
  (if newstate   (sqlite3:execute db "UPDATE tests SET state=?   WHERE id=?;" newstate   test-id))
  (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
  (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id)))

(define (db:get-count-tests-running db)

;;  	     ;;   		      tests))
;;  	     (completed-tests (let ((non-completed (make-hash-table)))
;;  				(for-each (lambda (x)
;;  					    ;; could add check for PASS here
;;  					    (if (not (and (equal? (db:test-get-state x) "COMPLETED")
;;  							  (equal? (db:test-get-status x) "PASS")))
;;  						(hash-table-set! non-completed (db:test-get-testname x) x)))
;;  					    ;; (print "Completed: " (db:test-get-testname x))))
;;  					    ;; (debug:print 0 "Completed: " (db:test-get-testname x))))
;;  					  tests)
;;  				(filter (lambda (x)
;;  					  (not (hash-table-ref/default non-completed (db:test-get-testname x) #f)))
;;  					tests)))
;;  	     (pre-dep-names   (map db:test-get-testname completed-tests))
;;  	     (result          (lset-difference string=? waiton pre-dep-names)))
;;  	(print "pre-dep-names: " pre-dep-names " waiton: " waiton " result: " result)

;; Mostly worked = puts out all combinations?
(define (process-itemlist-try1 curritemkey itemlist)
  (let loop ((hed (car itemlist))
	     (tal (cdr itemlist)))
    (if (null? tal)
	(for-each (lambda (item)
		    (print "curritemkey: " (append curritemkey (list item))))
		    (debug:print 6 "curritemkey: " (append curritemkey (list item))))
		  (cadr hed))
	(begin
	  (for-each (lambda (item)
		      (process-itemlist (append curritemkey (list item)) tal))
		    (cadr hed))
	  (loop (car tal)(cdr tal))))))

;; (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall")))
;;   => ((("ANIMAL" "Elephant") ("SEASON" "Spring")) 
;;       (("ANIMAL" "Elephant") ("SEASON" "Fall")) 
;;       (("ANIMAL" "Lion")     ("SEASON" "Spring"))
;;       (("ANIMAL" "Lion")     ("SEASON" "Fall")))
(define (item-assoc->item-list itemsdat)
  (if (and itemsdat (not (null? itemsdat)))
      (let ((itemlst (map (lambda (x)
			    (let ((name (car x))
				  (items (cadr x)))
			      (list name (string-split items))))
			  itemsdat)))
	(process-itemlist #f '() itemlst))
      (let ((itemlst (filter (lambda (x)
			       (list? x))
			     (map (lambda (x)
				    (debug:print 6 "item-assoc->item-list x: " x)
				    (if (< (length x) 2)
					(begin
					  (debug:print 0 "ERROR: malformed items spec " (string-intersperse x " "))
					  (list (car x)'()))
					(let ((name (car x))
					      (items (cadr x)))
					  (list name (string-split items)))))
				  itemsdat))))
	(let ((debuglevel 5))
	  (debug:print 5 "item-assoc->item-list: itemsdat => itemlst ")
	  (if (>= *verbosity* 5)
	      (begin
		(pp itemsdat)
		(print " => ")
		(pp itemlst))))
	(if (> (length itemlst) 0)
	    (process-itemlist #f '() itemlst)
	    '()))
      '())) ;; return a list consisting on a single null list for non-item runs
            ;; Nope, not now, return null as of 6/6/2011

;; (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter")))
;;   => ((("ANIMAL" "Elephant")("SEASON" "Spring"))
;;       (("ANIMAL" "Lion")    ("SEASON" "Winter")))
(define (item-table->item-list itemtable)
  (let ((newlst (map (lambda (x)
		       (if (> (length x) 1)
			   (list (car x)
				 (string-split (cadr x)))
			   x))
			   (list x '())))
		     itemtable))
	(res     '())) ;; a list of items
    (let loop ((indx    0)
	       (item   '()) ;; an item will be ((KEYNAME1 VAL1)(KEYNAME2 VAL2) ...)
	       (elflag  #f))
      (for-each (lambda (row)
		  (let ((rowname (car row))
			(rowdat  (cadr row)))
		    (set! item (append item 
				       (list 
					(if (< indx (length rowdat))
					    (let ((new (list rowname (list-ref rowdat indx))))
					      ;; (print "New: " new)
					      ;; (debug:print 0 "New: " new)
					      (set! elflag #t)
					      new
					      ) ;; i.e. had at least on legit value to use
					    (list rowname "-")))))))
		newlst)
      (if elflag
	  (begin

			  "SELECT fieldname,fieldtype FROM keys ORDER BY id ASC;")
    (reverse keys))) ;; could just sort desc?

;; get key vals for a given run-id
(define (get-key-vals db run-id)
  (let* ((keys (get-keys db))
	 (res  '()))
    ;; (print "keys: " keys " run-id: " run-id)
    (debug:print 6 "keys: " keys " run-id: " run-id)
    (for-each 
     (lambda (key)
       (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")))
	 ;; (print "qry: " qry)
	 ;; (debug:print 0 "qry: " qry)
	 (sqlite3:for-each-row 
	  (lambda (key-val)
	    (set! res (cons key-val res)))
	  db qry run-id)))
     keys)
    (reverse res)))

;; get key val pairs for a given run-id
;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
(define (keys:get-key-val-pairs db run-id)
  (let* ((keys (get-keys db))
	 (res  '()))
    ;; (print "keys: " keys " run-id: " run-id)
    (debug:print 6 "keys: " keys " run-id: " run-id)
    (for-each 
     (lambda (key)
       (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")))
	 ;; (print "qry: " qry)
	 ;; (debug:print 0 "qry: " qry)
	 (sqlite3:for-each-row 
	  (lambda (key-val)
	    (set! res (cons (list (key:get-fieldname key) key-val) res)))
	  db qry run-id)))
     keys)
    (reverse res)))

;; default => (val1 val2 val3 ...)
;; withkey => (:key1 val1 :key2 val2 :key3 val3 ...)
(define (keys->vallist keys . withkey) ;; ORDERING IS VERY IMPORTANT, KEEP PROPER ORDER HERE!
  (let* ((keynames   (map key:get-fieldname keys))
	 (argkeys    (map (lambda (k)(conc ":" k)) keynames))
	 (withkey    (not (null? withkey)))
	 (newremargs (args:get-args (cons "blah" remargs) argkeys '() args:arg-hash 0))) ;; the cons blah works around a bug in args [args assumes ("calling-prog-name" .... ) ]
    ;;(print "remargs: " remargs " newremargs: " newremargs)
    ;;(debug:print 0 "remargs: " remargs " newremargs: " newremargs)
    (apply append (map (lambda (x)
			 (let ((val (args:get-arg x)))
			   ;; (print "x: " x " val: " val)
			   ;; (debug:print 0 "x: " x " val: " val)
			   (if (not val)
			       ;; (print "WARNING: missing key " x ". Specified in database but not on command line, using \"unk\"")
			       ;; (debug:print 0 "WARNING: missing key " x ". Specified in database but not on command line, using \"unk\"")
			       (set! val "default"))
			   (if withkey (list x val) (list val))))
		       argkeys))))
  
;; (define (keys->alist keys)
;;   (let* ((keynames   (map key:get-fieldname keys))
;; 	 (argkeys    (map (lambda (k)(conc ":" k)) keynames))
;; 	 (withkey    (not (null? withkey)))
;; 	 (newremargs (args:get-args (cons "blah" remargs) argkeys '() args:arg-hash 0))) ;; the cons blah works around a bug in args
;;     (print "remargs: " remargs " newremargs: " newremargs)
;;     (debug:print 0 "remargs: " remargs " newremargs: " newremargs)
;;     (apply append (map (lambda (x)
;; 			 (let ((val (args:get-arg x)))
;; 			   (if (not val)
;; 			       (print "ERROR: Ignoring key " x " found in database but not on command line"))
;; 			       (debug:print 0 "ERROR: Ignoring key " x " found in database but not on command line"))
;; 			   (if withkey (list x val) (list val))))
;; 		       argkeys))))

(define (keystring->keys keystring)
  (map (lambda (x)
	 (let ((xlst (string-split x ":")))
	   (list->vector (if (> (length xlst) 1) xlst (append (car xlst)(list "TEXT"))))))

(define (setup-for-run)
  (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")))
  (set! *configdat*  (if (car *configinfo*)(car *configinfo*) #f))
  (set! *toppath*    (if (car *configinfo*)(cadr *configinfo*) #f))
  (if *toppath*
      (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated
      (print "ERROR: failed to find the top path to your run setup."))
      (debug:print 0 "ERROR: failed to find the top path to your run setup."))
  *toppath*)

(define (setup-env-defaults db fname run-id . already-seen)
  (let* ((keys    (get-keys db))
	 (keyvals (get-key-vals db run-id))
	 (thekey  (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))
	 (confdat (read-config fname))
	 (whatfound (make-hash-table))
	 (sections (list "default" thekey)))
    ;; (print "Using key=\"" thekey "\"")
    (debug:print 4 "Using key=\"" thekey "\"")
    (for-each 
     (lambda (section)
       (let ((section-dat (hash-table-ref/default confdat section #f)))
	 (if section-dat
	     (for-each 
	      (lambda (envvar)
		(hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1))
		(setenv envvar (cadr (assoc envvar section-dat))))
	      (map car section-dat)))))
     sections)
    (if (and (not (null? already-seen))
	     (not (car already-seen)))
	(begin
	  (print "Key settings found in runconfig.config:")
	  (debug:print 2 "Key settings found in runconfig.config:")
	  (for-each (lambda (fullkey)
		      (format #t "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0)))
		      (debug:print 2 (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))))
		    sections)
	  (print "---")
	  (debug:print 2 "---")
	  (set! *already-seen-runconfig-info* #t)))))

(define (get-best-disk confdat)
  (let* ((disks    (hash-table-ref/default confdat "disks" #f))
	 (best     #f)
	 (bestsize 0))
    (if disks 
	(for-each 
	 (lambda (disk-num)
	   (let* ((dirpath    (cadr (assoc disk-num disks)))
		  (freespc    (if (directory? dirpath)
				  (get-df dirpath)
				  (begin
				    (print "WARNING: path " dirpath " in [disks] section not valid")
				    (debug:print 0 "WARNING: path " dirpath " in [disks] section not valid")
				    0))))
	     (if (> freespc bestsize)
		 (begin
		   (set! best     dirpath)
		   (set! bestsize freespc)))))
	 (map car disks)))
    best))

	 (runsdir  (config-lookup *configdat* "setup" "runsdir"))
	 (lnkpath  (conc (if runsdir runsdir (conc *toppath* "/runs"))
			 "/" key-str "/" runname item-path)))
    ;; since this is an iterated test this is as good a place as any to
    ;; update the toptest record with its location rundir
    (if (not (equal? item-path ""))
	(db:test-set-rundir! db run-id testname "" toptest-path))
    (print "Setting up test run area")
    (print " - creating run area in " dfullp)
    (debug:print 2 "Setting up test run area")
    (debug:print 2 " - creating run area in " dfullp)
    (system  (conc "mkdir -p " dfullp))
    (print " - creating link from " dfullp "/" testname " to " lnkpath)
    (debug:print 2 " - creating link from " dfullp "/" testname " to " lnkpath)
    (system  (conc "mkdir -p " lnkpath))
    (if (file-exists? (conc lnkpath "/" testname))
	(system (conc "rm -f " lnkpath "/" testname)))
    (system  (conc "ln -sf " dfullp " " lnkpath "/" testname))
    (if (directory? dfullp)
	(begin
	  (system  (conc "rsync -av " test-path "/ " dfullp "/"))
	  (let* ((cmd    (conc "rsync -av" (if (> *verbosity* 1) "" "q") " " test-path "/ " dfullp "/"))
		 (status (system cmd)))
	    (if (not (eq? status 0))
		(debug:print 2 "ERROR: problem with running \"" cmd "\"")))
	  (list dfullp toptest-path))
	(list #f #f))))

;; 1. look though disks list for disk with most space
;; 2. create run dir on disk, path name is meaningful
;; 3. create link from run dir to megatest runs area 
;; 4. remotely run the test on allocated host

    (set! diskpath (get-best-disk *configdat*))
    (if diskpath
	(let ((dat  (create-work-area db run-id test-path diskpath test-name itemdat)))
	  (set! work-area (car dat))
	  (set! toptest-work-area (cadr dat)))
	(begin
	  (set! work-area test-path)
	  (print "WARNING: No disk work area specified - running in the test directory")))
	  (debug:print 0 "WARNING: No disk work area specified - running in the test directory")))
    (set! cmdparms (base64:base64-encode (with-output-to-string
				    (lambda () ;; (list 'hosts     hosts)
				      (write (list (list 'testpath  test-path)
						   (list 'work-area work-area)
						   (list 'test-name test-name) 
						   (list 'runscript runscript) 
						   (list 'run-id    run-id   )

     ((and launcher hosts) ;; must be using ssh hostname
      (set! fullcmd (append launcher (car hosts)(list remote-megatest "-execute" cmdparms))))
     (launcher
      (set! fullcmd (append launcher (list remote-megatest "-execute" cmdparms))))
     (else
      (set! fullcmd (list remote-megatest "-execute" cmdparms))))
    (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm"))))
    (print "Launching megatest for test " test-name " in " work-area" ...")
    (debug:print 1 "Launching megatest for test " test-name " in " work-area" ...")
    (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat) ;; (if launch-results launch-results "FAILED"))
    ;; set 
    ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done
    (let* ((commonprevvals (alist->env-vars
			    (hash-table-ref/default *configdat* "env-override" '())))
	   (testprevvals   (alist->env-vars
			    (hash-table-ref/default test-conf "pre-launch-env-overrides" '())))
	   (miscprevvals   (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute"
			    (append (list (list "MT_TEST_NAME" test-name)
					  (list "MT_ITEM_INFO" (conc itemdat)) 
					  (list "MT_RUNNAME"   (args:get-arg ":runname")))
				    itemdat)))
	   (launch-results (apply cmd-run-proc-each-line
				  (car fullcmd)
				  print
				  (cdr fullcmd)))) ;;  launcher fullcmd)));; (apply cmd-run-proc-each-line launcher print fullcmd))) ;; (cmd-run->list fullcmd))
      (print "Launching completed, updating db")
      (debug:print 2 "Launching completed, updating db")
      (alist->env-vars miscprevvals)
      (alist->env-vars testprevvals)
      (alist->env-vars commonprevvals))))

;; Copyright 2006-2011, 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.

(include "common.scm")
(define megatest-version 1.12)
(define megatest-version 1.17)

(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2011

Usage: megatest [options]

			"-itempatt"
			"-setlog"
			"-set-toplog"
			"-runstep"
			"-logpro"
			"-m"
			"-rerun"
			"-debug" ;; for *verbosity* > 2
			) 
		 (list  "-h"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-test-status"
		        "-gui"
			"-runall"    ;; run all tests
			"-remove-runs"
			"-keepgoing"
			"-usequeue"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only
		       )
		 args:arg-hash
		 0))

(if (args:get-arg "-h")
    (begin
      (print help)

(define *didsomething* #f)

;;======================================================================
;; Misc setup stuff
;;======================================================================

(set! *verbosity* (cond
		   ((args:get-arg "-debug")(string->number (args:get-arg "-debug")))
		   ((args:get-arg "-v")    2)
		   ((args:get-arg "-q")    0)
		   (else                   1)))

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

;; since several actions can be specified on the command line the removal
;; is done first
(define (remove-runs)
  (cond
   ((not (args:get-arg ":runname"))
    (print "ERROR: Missing required parameter for -remove-runs, you must specify the run name pattern with :runname patt")
    (debug:print 0 "ERROR: Missing required parameter for -remove-runs, you must specify the run name pattern with :runname patt")
    (exit 2))
   ((not (args:get-arg "-testpatt"))
    (print "ERROR: Missing required parameter for -remove-runs, you must specify the test pattern with -testpatt")
    (debug:print 0 "ERROR: Missing required parameter for -remove-runs, you must specify the test pattern with -testpatt")
    (exit 3))
   ((not (args:get-arg "-itempatt"))
    (print "ERROR: Missing required parameter for -remove-runs, you must specify the items with -itempatt")
    (exit 4))
   ((let ((db #f))
      (if (not (setup-for-run))
	  (begin 
	    (print "Failed to setup, exiting")
	    (debug:print 0 print "Failed to setup, exiting")
	    (exit 1)))
      (set! db (open-db))
      (if (not (car *configinfo*))
	  (begin
	    (print "ERROR: Attempted to remove test(s) but run area config file not found")
	    (debug:print 0 "ERROR: Attempted to remove test(s) but run area config file not found")
	    (exit 1))
	  ;; put test parameters into convenient variables
	  (runs:remove-runs db
			    (args:get-arg ":runname")
			    (args:get-arg "-testpatt")
			    (args:get-arg "-itempatt")))
      (sqlite3:finalize! db)

	   (runs     (db:get-rows runsdat))
	   (header   (db:get-header runsdat))
	   (keys     (db-get-keys db))
	   (keynames (map key:get-fieldname keys)))
      ;; Each run
      (for-each 
       (lambda (run)
	 (print "Run: "
	 (debug:print 2 "Run: "
		(string-intersperse (map (lambda (x)
					   (db:get-value-by-header run header x))
					 keynames) "/")
		"/"
		(db:get-value-by-header run header "runname"))
	 (let ((run-id (db:get-value-by-header run header "id")))
	   (let ((tests (db-get-tests-for-run db run-id testpatt itempatt)))

			 (lambda (step)
			   (format #t 
				   "    Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
				   (db:step-get-stepname step)
				   (db:step-get-state step)
				   (db:step-get-status step)
				   (db:step-get-event_time step)))
			;;    (print "    Step: " (db:step-get-stepname step)
			;; 	  " " (db:step-get-state step)
			;; 	  " " (db:step-get-status step)
			;; 	  " " (db:step-get-event_time step)))
			 steps)))))
		tests))))
       runs)
      (set! *didsomething* #t)
      ))

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

;; if still ok to run tasks
;;   process deferred tasks per above steps

;; run all tests are are Not COMPLETED and PASS or CHECK
(if (args:get-arg "-runall")
    (if (not (args:get-arg ":runname"))
	(begin
	  (print "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname")
	  (debug:print 0 "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname")
	  (exit 2))
	(let* ((db      (if (setup-for-run)
			    (open-db)
			    (begin
			      (print "Failed to setup, exiting")
			      (debug:print 0 "Failed to setup, exiting")
			      (exit 1)))))
	  (if (not (car *configinfo*))
	      (begin
		(print "ERROR: Attempted to run a test but run area config file not found")
		(debug:print 0 "ERROR: Attempted to run a test but run area config file not found")
		(exit 1))
	      ;; put test parameters into convenient variables
	      (let* ((test-names (get-all-legal-tests))) ;; "PROD" is ignored for now
		(print "INFO: Attempting to start the following tests...")
		(print "     " (string-intersperse test-names ","))
		(debug:print 1 "INFO: Attempting to start the following tests...")
		(debug:print 1 "     " (string-intersperse test-names ","))
		(run-tests db test-names)))
	  ;; (run-waiting-tests db)
	  (sqlite3:finalize! db)
	  (set! *didsomething* #t))))

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

;; 6. test phone home
;;    - if test run time > allowed run time then kill job
;;    - if cannot access db > allowed disconnect time then kill job

(define (runtests)
  (if (not (args:get-arg ":runname"))
      (begin
	(print "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname")
	(debug:print 0 "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname")
	(exit 2))
      (let ((db #f))
	(if (not (setup-for-run))
	    (begin 
	      (print "Failed to setup, exiting")
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(set! db (open-db))
	(if (not (car *configinfo*))
	    (begin
	      (print "ERROR: Attempted to run a test but run area config file not found")
	      (debug:print 0 "ERROR: Attempted to run a test but run area config file not found")
	      (exit 1))
	    ;; put test parameters into convenient variables
	    (let* ((test-names   (string-split (args:get-arg "-runtests") ",")))
	      (run-tests db test-names)))
	;; run-waiting-tests db)
	(sqlite3:finalize! db)
	;; (run-waiting-tests #f)

		 (itemdat   (assoc/default 'itemdat   cmdinfo))
		 (env-ovrd  (assoc/default 'env-ovrd  cmdinfo))
		 (runname   (assoc/default 'runname   cmdinfo))
		 (megatest  (assoc/default 'megatest  cmdinfo))
		 (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo))
		 (fullrunscript (conc testpath "/" runscript))
		 (db        #f))
	    (print "Exectuing " test-name " on " (get-host-name))
	    (debug:print 2 "Exectuing " test-name " on " (get-host-name))
	    (change-directory testpath)
	    (setenv "MT_TEST_RUN_DIR" work-area)
	    (setenv "MT_TEST_NAME" test-name)
	    (setenv "MT_ITEM_INFO" (conc itemdat))
	    (setenv "MT_RUNNAME"   runname)
	    (setenv "MT_MEGATEST"  megatest)
	    (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))
	    
	    (if (not (setup-for-run))
		(begin
		  (print "Failed to setup, exiting") 
		  (debug:print 0 "Failed to setup, exiting") 
		  (exit 1)))
	    ;; now can find our db
	    (set! db (open-db))
	    (change-directory work-area) 
	    (let ((runconfigf (conc  *toppath* "/runconfigs.config")))
	      (if (file-exists? runconfigf)
		  (setup-env-defaults db runconfigf run-id)
		  (print "WARNING: You do not have a run config file: " runconfigf)))
		  (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)))
            ;; environment overrides are done *before* the remaining critical envars.
            (alist->env-vars env-ovrd)
	    (set-megatest-env-vars db run-id)
	    (set-item-env-vars itemdat)
            (save-environment-as-files "megatest")
	    (test-set-meta-info db run-id test-name itemdat)
	    (test-set-status! db run-id test-name "REMOTEHOSTSTART" "n/a" itemdat (args:get-arg "-m"))

					 (test-update-meta-info db run-id test-name itemdat minutes)
					 (if kill-job? 
					     (begin
					       (mutex-lock! m)
					       (let* ((pid (vector-ref exit-info 0)))
						 (if (number? pid)
						     (begin
						       (print "WARNING: Request received to kill job (attempt # " kill-tries ")")
						       (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")")
						       ;;(cond
						       ;;((>   kill-tries 0) ; 2)
						       (let ((processes (cmd-run->list (conc "pgrep -l -P " pid))))
							 (for-each 
							  (lambda (p)
							    (let* ((parts  (string-split p))
								   (p-id   (if (> (length parts) 0)
									       (string->number (car parts))
									       #f)))
							      (if p-id
								  (begin
								    (print "Killing " (cadr parts) "; kill -9  " p-id)
								    (debug:print 0 "Killing " (cadr parts) "; kill -9  " p-id)
								    (system (conc "kill -9 " p-id))))))
							  (car processes))
							 (system (conc "kill -9 " pid))))
						     ;;(let* ((ppid (process-group-id pid))
						     ;;       (kcmd (conc "pkill -9 -g " ppid)))
						     ;;  ;; (process-signal pid signal/term)
						     ;;  ;; (process-signal pid signal/kill)
						     ;;  (print "Attempting to kill pid " pid " and children in process group " ppid " with command:\n    " kcmd)
						     ;;  (print "Children:")
						     ;;  (debug:print 0 "Attempting to kill pid " pid " and children in process group " ppid " with command:\n    " kcmd)
						     ;;  (debug:print 0 "Children:")
						     ;;  (system (conc "pgrep -g -l " ppid))
						     ;;  (system kcmd)
						     ;;  (sleep 1) ;; give it a rest
						     ;;  (test-set-status! db run-id test-name "KILLED"  "FAIL"
						     ;;       	     itemdat (args:get-arg "-m"))
						     ;;  (sqlite3:finalize! db)
						     ;;  (exit 1)))))
						     (begin
						       (print "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
						       (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
						       (test-set-status! db run-id test-name "KILLED"  "FAIL"
									 itemdat (args:get-arg "-m"))
						       (sqlite3:finalize! db)
						       (exit 1))))
					       ;;     (thread-terminate! job-thread)))
					       (set! kill-tries (+ 1 kill-tries))
					       (mutex-unlock! m)))
					 ;; (handle-exceptions
					       ;;  exn
					       ;;  (begin
					       ;;    (print "ERROR: Problem killing process " (vector-ref exit-info 0))
					       ;;    (debug:print 0 "ERROR: Problem killing process " (vector-ref exit-info 0))
					       ;;    (abort exn))
					       ;;  (let* ((pid   (vector-ref exit-info 0))
					       ;;         ;; (pgid  (process-group-id pid))
					       ;;         ;; (cmd  (conc "pkill -9 -P " pgid))
					       ;;         )
					       ;;    ;; (print "Running \"" cmd "\"")
					       ;;    ;; (debug:print 0 "Running \"" cmd "\"")
					       ;;    ;; (system cmd)
					       ;;    (print "Running \"kill -9 " pid "\"")
					       ;;    (debug:print 0 "Running \"kill -9 " pid "\"")
					       ;;    (system (conc "kill -9 " pid))
					       ;;    ;; (process-signal (vector-ref exit-info 0) signal/kill)
					       ;;    ))))
					 (sqlite3:finalize! db)
					 (thread-sleep! (+ 8 (random 4))) ;; add some jitter to the call home time to spread out the db accesses
					 (loop (calc-minutes)))))))
		   (th1          (make-thread monitorjob))
		   (th2          (make-thread runit)))
	      (set! job-thread th2)
	      (thread-start! th1)
	      (thread-start! th2)
	      (thread-join! th2)
	      (mutex-lock! m)
	      (set! db (open-db))
	      (let* ((testinfo (db:get-test-info db run-id test-name (item-list->path itemdat))))
		(if (not (equal? (db:test-get-state testinfo) "COMPLETED"))
		    (begin
		      (print "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result")
		      (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result")
		      (test-set-status! db run-id test-name
					(if kill-job? "KILLED" "COMPLETED")
					(if (vector-ref exit-info 1) ;; look at the exit-status
					    (if (and (not kill-job?) 
						     (eq? (vector-ref exit-info 2) 0))
						"PASS"
						"FAIL")
					    "FAIL") itemdat (args:get-arg "-m")))))
	      (mutex-unlock! m)
	      ;; (exec-results (cmd-run->list fullrunscript)) ;;  (list ">" (conc test-name "-run.log"))))
	      ;; (success      exec-results)) ;; (eq? (cadr exec-results) 0)))
	      (print "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " 
	      (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " 
		     work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
	      (sqlite3:finalize! db)
	      (if (not (vector-ref exit-info 1))
		  (exit 4)))))
      (set! *didsomething* #t)))

(if (args:get-arg "-step")
    (if (not (getenv "MT_CMDINFO"))
	(begin
	  (print "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
	  (debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
	  (exit 5))
	(let* ((step      (args:get-arg "-step"))
	       (cmdinfo   (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))
	       (testpath  (assoc/default 'testpath  cmdinfo))
	       (test-name (assoc/default 'test-name cmdinfo))
	       (runscript (assoc/default 'runscript cmdinfo))
	       (db-host   (assoc/default 'db-host   cmdinfo))
	       (run-id    (assoc/default 'run-id    cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (db        #f)
	       (state    (args:get-arg ":state"))
	       (status   (args:get-arg ":status")))
	  (change-directory testpath)
	  (if (not (setup-for-run))
	      (begin
		(print "Failed to setup, exiting")
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))
	  (set! db (open-db))
	  (if (and state status)
	      (teststep-set-status! db run-id test-name step state status itemdat (args:get-arg "-m"))
	      (begin
		(print "ERROR: You must specify :state and :status with every call to -step")
		(debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
		(exit 6)))
	  (sqlite3:finalize! db)
	  (set! *didsomething* #t))))

(if (or (args:get-arg "-setlog")       ;; since setting up is so costly lets piggyback on -test-status
	(args:get-arg "-set-toplog")
	(args:get-arg "-test-status")
	(args:get-arg "-runstep"))
    (if (not (getenv "MT_CMDINFO"))
	(begin
	  (print "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
	  (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
	  (exit 5))
	(let* ((startingdir (current-directory))
	       (cmdinfo   (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))
	       (testpath  (assoc/default 'testpath  cmdinfo))
	       (test-name (assoc/default 'test-name cmdinfo))
	       (runscript (assoc/default 'runscript cmdinfo))
	       (db-host   (assoc/default 'db-host   cmdinfo))
	       (run-id    (assoc/default 'run-id    cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (db        #f)
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status")))
	  (change-directory testpath)
	  (if (not (setup-for-run))
	      (begin
		(print "Failed to setup, exiting")
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))
	  (set! db (open-db))
	  (if (args:get-arg "-setlog")
	      (test-set-log! db run-id test-name itemdat (args:get-arg "-setlog")))
	  (if (args:get-arg "-set-toplog")
	      (test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
	  (if (args:get-arg "-runstep")
	      (if (null? remargs)
		  (begin
		    (print "ERROR: nothing specified to run!")
		    (debug:print 0 "ERROR: nothing specified to run!")
		    (sqlite3:finalize! db)
		    (exit 6))
		  (let* ((stepname   (args:get-arg "-runstep"))
			 (logprofile (args:get-arg "-logpro"))
			 (logfile    (conc stepname ".log"))
			 (cmd        (if (null? remargs) #f (car remargs)))
			 (params     (if cmd (cdr remargs) '()))
			 (exitstat   #f)
			 (shell      (last (string-split (get-environment-variable "SHELL") "/")))
			 (redir      (case (string->symbol shell)
				       ((tcsh csh ksh)    ">&")
				       ((zsh bash sh ash) "2>&1 >")))
			 (fullcmd    (conc "(" (string-intersperse 
						(cons cmd params) " ")
					   ") " redir " " logfile)))
		    ;; mark the start of the test
		    (teststep-set-status! db run-id test-name stepname "start" "n/a" itemdat (args:get-arg "-m"))
		    ;; close the db
		    (sqlite3:finalize! db)
		    ;; run the test step
		    (print "INFO: Running \"" fullcmd "\"")
		    (debug:print 2 "INFO: Running \"" fullcmd "\"")
		    (change-directory startingdir)
		    (set! exitstat (system fullcmd)) ;; cmd params))
		    (set! *globalexitstatus* exitstat)
		    (change-directory testpath)
		    ;; re-open the db
		    (set! db (open-db)) 
		    ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
		    (if logprofile
			(let* ((htmllogfile (conc stepname ".html"))
			       (oldexitstat exitstat)
			       (cmd         (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
			  (print "INFO: running \"" cmd "\"")
			  (debug:print 2 "INFO: running \"" cmd "\"")
			  (change-directory startingdir)
			  (set! exitstat (system cmd))
			  (set! *globalexitstatus* exitstat) ;; no necessary
			  (change-directory testpath)
			  (test-set-log! db run-id test-name itemdat htmllogfile)))
		    (teststep-set-status! db run-id test-name stepname "end" exitstat itemdat (args:get-arg "-m"))
		    (sqlite3:finalize! db)

				((number? status)       (if (equal? status 0) "PASS" "FAIL"))
				((string->number status)(if (equal? (string->number status) 0) "PASS" "FAIL"))
				(else status))))
		(test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m")))
	      (if (and state status)
		  (if (not (args:get-arg "-setlog"))
		      (begin
			(print "ERROR: You must specify :state and :status with every call to -test-status\n" help)
			(debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help)
			(sqlite3:finalize! db)
			(exit 6)))))
	  (sqlite3:finalize! db)
	  (set! *didsomething* #t))))

(if (args:get-arg "-showkeys")
    (let ((db #f)
	  (keys #f))
      (if (not (setup-for-run))
	  (begin
	    (print "Failed to setup, exiting")
	    (debug:print 0 "Failed to setup, exiting")
	    (exit 1)))
      (set! db (open-db))
      (set! keys (db-get-keys db))
      (print "Keys: " (string-intersperse (map key:get-fieldname keys) ", "))
      (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", "))
      (sqlite3:finalize! db)
      (set! *didsomething* #t)))

(if (args:get-arg "-gui")
    (begin
      (print "Look at the dashboard for now")
      (debug:print 0 "Look at the dashboard for now")
      ;; (megatest-gui)
      (set! *didsomething* #t)))

(if (not *didsomething*)
    (print help))
    (debug:print 0 help))

(if (not (eq? *globalexitstatus* 0))
    (if (or (args:get-arg "-runtests")(args:get-arg "-runall"))
        (begin
           (print "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
           (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
           (exit 0))
        (case *globalexitstatus*
         ((0)(exit 0))
         ((1)(exit 1))
         ((2)(exit 2))
         (else (exit 3)))))

	 (keyvallst (keys->vallist keys)) ;; extracts the values from remainder of (argv)
	 (runname   (get-with-default ":runname" #f))
	 (state     (get-with-default ":state" "no"))
	 (status    (get-with-default ":status" "n/a"))
	 (allvals   (append (list runname state status user) keyvallst))
	 (qryvals   (append (list runname) keyvallst))
	 (key=?str  (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND ")))
    ;; (print "keys: " keys " allvals: " allvals " keyvallst: " keyvallst)
    (print "NOTE: using key " (string-intersperse keyvallst "/") " for this run")
    (debug:print 3 "keys: " keys " allvals: " allvals " keyvallst: " keyvallst)
    (debug:print 2 "NOTE: using key " (string-intersperse keyvallst "/") " for this run")
    (if (and runname (null? (filter (lambda (x)(not x)) keyvallst))) ;; there must be a better way to "apply and"
	(let ((res #f))
	  (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");")
		 allvals)
	  (apply sqlite3:for-each-row 
	   (lambda (id)
	     (set! res id))
	   db
	   (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
	     ;; (print "qry: " qry) 
	     ;(debug:print 4 "qry: " qry) 
	     qry)
	   qryvals)
	  (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res)
	  res) 
	(begin
	  (print "ERROR: Called without all necessary keys")
	  (debug:print 0 "ERROR: Called without all necessary keys")
	  #f))))

;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))

    (for-each (lambda (keyval)
		(let* ((key    (vector-ref keyval 0))
		       (fulkey (conc ":" key))
		       (patt   (args:get-arg fulkey)))
		  (if patt
		      (set! key-patt (conc key-patt " AND " key " like '" patt "'"))
		      (begin
			(print "ERROR: searching for runs with no pattern set for " fulkey)
			(debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
			(exit 6)))))
	      keys)
    (sqlite3:for-each-row 
     (lambda (a . r)
       (set! res (cons (list->vector (cons a r)) res)))
     db 
     (conc "SELECT " keystr " FROM runs WHERE runname like ? " key-patt ";")

			(if s (string-split s) #f))))
    (if valid-values
	(if (member item valid-values)
	    item #f)
	item)))

(define (teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment)
  ;; (print "run-id: " run-id " test-name: " test-name)
  (debug:print 4 "run-id: " run-id " test-name: " test-name)
  (let* ((state     (check-valid-items "state" state-in))
	 (status    (check-valid-items "status" status-in))
	 (item-path (item-list->path itemdat))
	 (testdat   (db:get-test-info db run-id test-name item-path)))
    ;; (print "testdat: " testdat)
    (debug:print 5 "testdat: " testdat)
    (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works.
	     (or (not state)(not status)))
	(print "WARNING: Invalid " (if status "status" "state")
	(debug:print 0 "WARNING: Invalid " (if status "status" "state")
	       " value \"" (if status status-in state-in) "\", update your validstates section in megatest.config"))
    (if testdat
	(let ((test-id (test:get-id testdat)))
	  (sqlite3:execute db 
			"INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment) VALUES(?,?,?,?,strftime('%s','now'),?);"
			test-id teststep-name state status (if comment comment "")))
	(print "ERROR: Can't update " test-name " for run " run-id " -> no such test in db"))))
	(debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db"))))

(define (test-get-kill-request db run-id test-name itemdat)
  (let* ((item-path (item-list->path itemdat))
	 (testdat   (db:get-test-info db run-id test-name item-path)))
    (equal? (test:get-state testdat) "KILLREQ")))

(define (test-set-meta-info db run-id testname itemdat)

		  testname
		  item-path)))

(define (test-update-meta-info db run-id testname itemdat minutes)
  (let ((item-path (item-list->path itemdat))
	(cpuload  (get-cpu-load))
	(diskfree (get-df (current-directory))))
    (if (not cpuload)  (begin (print "WARNING: CPULOAD not found.")  (set! cpuload "n/a")))
    (if (not diskfree) (begin (print "WARNING: DISKFREE not found.") (set! diskfree "n/a")))
    (if (not item-path)(begin (print "WARNING: ITEMPATH not set.")   (set! item-path "")))
    (if (not cpuload)  (begin (debug:print 0 "WARNING: CPULOAD not found.")  (set! cpuload "n/a")))
    (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a")))
    (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.")   (set! item-path "")))
    ;; (let ((testinfo (db:get-test-info db run-id testname item-path)))
    ;;   (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED"))
    ;;            (not (equal? (db:test-get-status testinfo) "KILLREQ"))
    (sqlite3:execute
     db
     "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');"
     cpuload
     diskfree
     minutes
     run-id
     testname
     item-path)))

(define (set-megatest-env-vars db run-id)
  (let ((keys (db-get-keys db)))
    (for-each (lambda (key)
		(sqlite3:for-each-row
		 (lambda (val)
		   (print "setenv " (key:get-fieldname key) " " val)
		   (debug:print 2 "setenv " (key:get-fieldname key) " " val)
		   (setenv (key:get-fieldname key) val))
		 db 
		 (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")
		 run-id))
	      keys)))

(define (set-item-env-vars itemdat)
  (for-each (lambda (item)
	      (print "setenv " (car item) " " (cadr item))
	      (debug:print 2 "setenv " (car item) " " (cadr item))
	      (setenv (car item) (cadr item)))
	    itemdat))

(define (get-all-legal-tests)
  (let* ((tests  (glob (conc *toppath* "/tests/*")))
	 (res    '()))
    ;; (print "INFO: Looking at tests " (string-intersperse tests ","))
    (debug:print 4 "INFO: Looking at tests " (string-intersperse tests ","))
    (for-each (lambda (testpath)
		(if (file-exists? (conc testpath "/testconfig"))
		    (set! res (cons (last (string-split testpath "/")) res))))
	      tests)
    res))

(define (runs:can-run-more-tests db)
  (let ((num-running (db:get-count-tests-running db))
	(max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")))
    ;; (print "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
    (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
    (if (or (not max-concurrent-jobs)
	    (and max-concurrent-jobs
		 (string->number max-concurrent-jobs)
		 (not (>= num-running (string->number max-concurrent-jobs)))))
	#t
	(begin 
	  (print "WARNING: Max running jobs exceeded, current number running: " num-running 
	  (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running 
			 ", max_concurrent_jobs: " max-concurrent-jobs)
	  #f))))
  
(define (run-tests db test-names)
  (let* ((keys        (db-get-keys db))
	 (keyvallst   (keys->vallist keys #t))
	 (run-id      (register-run db keys))) ;;  test-name)))
    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified
    (if (and (eq? *passnum* 0)
	     (args:get-arg "-keepgoing"))
	(begin
	  ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to 
	  ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends 
	  ;; on test A but test B reached the point on being registered as NOT_STARTED and test
	  ;; A failed for some reason then on re-run using -keepgoing the run can never complete.
	  (db:delete-tests-in-state db run-id "NOT_STARTED")
	(db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))
	  (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
    (set! *passnum* (+ *passnum* 1))
    (let loop ((numtimes 0))
      (for-each 
       (lambda (test-name)
	 (if (runs:can-run-more-tests db)
	     (run-one-test db run-id test-name keyvallst)
	     ;; add some delay 
	     (sleep 2)))
       test-names)
      ;; (run-waiting-tests db)
      (if (args:get-arg "-keepgoing")
	  (let ((estrem (db:estimated-tests-remaining db run-id)))
	    (if (> estrem 0)
		(begin
		  (print "Keep going, estimated " estrem " tests remaining to run, will continue in 10 seconds ...")
		  (sleep 10)
		  (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...")
		  (sleep 3)
		  (run-waiting-tests db)
		  (loop (+ numtimes 1)))))))))
	   
;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc
(define (run-one-test db run-id test-name keyvallst)
  (print "Launching test " test-name)
  (debug:print 1 "Launching test " test-name)
  ;; All these vars might be referenced by the testconfig file reader
  (setenv "MT_TEST_NAME" test-name) ;; 
  (setenv "MT_RUNNAME"   (args:get-arg ":runname"))
  (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
  (change-directory *toppath*)
  (let* ((test-path    (conc *toppath* "/tests/" test-name))
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	 (test-conf    (if testexists (read-config test-configf) (make-hash-table)))
	 (waiton       (let ((w (config-lookup test-conf "requirements" "waiton")))
			 (if (string? w)(string-split w)'()))))
    (if (not testexists)
	(begin
	  (print "ERROR: Can't find config file " test-configf)
	  (debug:print 0 "ERROR: Can't find config file " test-configf)
	  (exit 2))
	;; put top vars into convenient variables and open the db
	(let* (;; db is always at *toppath*/db/megatest.db
	       (items       (hash-table-ref/default test-conf "items" '()))
	       (itemstable  (hash-table-ref/default test-conf "itemstable" '()))
	       (allitems    (if (or (not (null? items))(not (null? itemstable)))
				(append (item-assoc->item-list items)
					(item-table->item-list itemstable))
				'(()))) ;; a list with one null list is a test with no items
	       (runconfigf  (conc  *toppath* "/runconfigs.config")))
	  (debug:print 1 "items: ")
	  (if (>= *verbosity* 1)(pp allitems))
	  (if (>= *verbosity* 5)
	      (begin
	  (print "items: ")(pp allitems)
		(print "items: ")(pp (item-assoc->item-list items))
		(print "itestable: ")(pp (item-table->item-list itemstable))))
	  (if (args:get-arg "-m")
	      (db:set-comment-for-run db run-id (args:get-arg "-m")))
	  ;; braindead work-around for poorly specified allitems list BUG!!! FIXME
	  (if (null? allitems)(set! allitems '(())))
	  (let loop ((itemdat (car allitems))
		     (tal     (cdr allitems)))
	    ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
	    ;; Handle lists of items
	    (let* ((item-path     (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
		   (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
		   (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
		   (testdat   #f)
		   (num-running (db:get-count-tests-running db))
		   (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))
		   (parent-test (and (not (null? items))(equal? item-path "")))
		   (single-test (and (null? items) (equal? item-path "")))
		   (item-test   (not (equal? item-path ""))))
	      ;; (print "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
	      (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
	      (if (runs:can-run-more-tests db)
		  (begin
		    (let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #f)
				(ct 0))
		      (if (and (not ts)
			       (< ct 10))
			  (begin
			    (register-test db run-id test-name item-path)
			    (db:test-set-comment db run-id test-name item-path "")
			    (loop2 (db:get-test-info db run-id test-name item-path)
				   (+ ct 1)))
			  (if ts
			      (set! testdat ts)
			      (begin
				(print "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
				(debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
				(if (not (null? tal))
				    (loop (car tal)(cdr tal)))))))
		    (change-directory test-path)
		    ;; this block is here only to inform the user early on
		    (if (file-exists? runconfigf)
			(setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*)
			(print "WARNING: You do not have a run config file: " runconfigf))
		    ;; (print "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat))
			(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
		    (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat))
		    (case (if (args:get-arg "-force")
			      'NOT_STARTED
			      (if testdat
				  (string->symbol (test:get-state testdat))
				  'failed-to-insert))
		      ((failed-to-insert)
		       (print "ERROR: Failed to insert the record into the db"))
		       (debug:print 0 "ERROR: Failed to insert the record into the db"))
		      ((NOT_STARTED COMPLETED)
		       ;; (print "Got here, " (test:get-state testdat))
		       (debug:print 6 "Got here, " (test:get-state testdat))
		       (let ((runflag #f))
			 (cond
			  ;; i.e. this is the parent test to a suite of items, never "run" it
			  (parent-test
			   (set! runflag #f))
			  ;; -force, run no matter what
			  ((args:get-arg "-force")(set! runflag #t))

			  ((and (args:get-arg "-keepgoing")
				(member (test:get-status testdat) '("FAIL")))
			   (set! runflag #f))
			  ((and (not (args:get-arg "-rerun"))
				(member (test:get-status testdat) '("FAIL" "n/a")))
			   (set! runflag #t))
			  (else (set! runflag #f)))
			 ;; (print "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
			 (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
			 (if (not runflag)
			     (if (not parent-test)
				 (print "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override"))
				 (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override"))
			     (let* ((get-prereqs-cmd (lambda ()
						       (db-get-prereqs-not-met db run-id waiton))) ;; check before running ....
				    (launch-cmd      (lambda ()
						       (launch-test db run-id test-conf keyvallst test-name test-path itemdat)))
				    (testrundat      (list get-prereqs-cmd launch-cmd)))
			       (if (or (args:get-arg "-force")
				       (null? ((car testrundat)))) ;; are there any tests that must be run before this one...
				   ((cadr testrundat)) ;; this is the line that launches the test to the remote host
				   (if (not (args:get-arg "-keepgoing"))
				       (hash-table-set! *waiting-queue* new-test-name testrundat)))))))
		      ((KILLED) 
		       (print "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
		       (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
		      ((LAUNCHED REMOTEHOSTSTART RUNNING)  
		       (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
						     (db:test-get-run_duration testdat)))
			      100) ;; i.e. no update for more than 100 seconds
			   (begin
			     (print "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
			     (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
			     (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead"))
			   (print "NOTE: " test-name " is already running")))
		      (else       (print "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))
			   (debug:print 2 "NOTE: " test-name " is already running")))
		      (else       (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))
	      (if (not (null? tal))
		  (loop (car tal)(cdr tal)))))))))

(define (run-waiting-tests db)
  (let ((numtries           0)
	(last-try-time      (current-seconds))
	(times              (list 1))) ;; minutes to wait before trying again to kick off runs
    ;; BUG this hack of brute force retrying works quite well for many cases but 
    ;;     what is needed is to check the db for tests that have failed less than
    ;;     N times or never been started and kick them off again
    (let loop ((waiting-test-names (hash-table-keys *waiting-queue*)))
      (cond
       ((not (runs:can-run-more-tests db))
	(sleep 2)
	(loop waiting-test-names))
       ((null? waiting-test-names)
	(print "All tests launched"))
	(debug:print 1 "All tests launched"))
       (else
	(set! numtries (+ numtries 1))
	(for-each (lambda (testname)
		    (if (runs:can-run-more-tests db)
			(let* ((testdat (hash-table-ref *waiting-queue* testname))
			       (prereqs ((car testdat)))
			       (ldb     (if db db (open-db))))
			  ;; (print "prereqs remaining: " prereqs)
			  (debug:print 2 "prereqs remaining: " prereqs)
			  (if (null? prereqs)
			      (begin
				(print "Prerequisites met, launching " testname)
				(debug:print 2 "Prerequisites met, launching " testname)
				((cadr testdat))
				(hash-table-delete! *waiting-queue* testname)))
			  (if (not db)
			      (sqlite3:finalize! ldb)))))
		  waiting-test-names)
	;; (sleep 10) ;; no point in rushing things at this stage?
	(loop (hash-table-keys *waiting-queue*)))))))

(define (get-dir-up-one dir) 
  (let ((dparts  (string-split dir "/")))
(define (get-dir-up-n dir . params) 
  (let ((dparts  (string-split dir "/"))
	(count   (if (null? params) 1 (car params))))
    (conc "/" (string-intersperse 
	       (take dparts (- (length dparts) 1))
	       (take dparts (- (length dparts) count))
	       "/"))))
;; Remove runs
;; fields are passing in through 
(define (runs:remove-runs db runnamepatt testpatt itempatt)
  (let* ((keys        (db-get-keys db))
	 (rundat      (runs:get-runs-by-patt db keys runnamepatt))
	 (header      (vector-ref rundat 0))
	 (runs        (vector-ref rundat 1)))
    (print "Header: " header)
    (debug:print 1 "Header: " header)
    (for-each
     (lambda (run)
       (let ((runkey (string-intersperse (map (lambda (k)
						(db:get-value-by-header run header (vector-ref k 0))) keys) "/")))
	 (let* ((run-id (db:get-value-by-header run header "id") )
		(tests  (db-get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt))
		(lasttpath "/does/not/exist/I/hope"))
	   (if (not (null? tests))
	       (begin
		 (print "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
		 (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
		 (for-each
		  (lambda (test)
		    (let* ((item-path (db:test-get-item-path test))
			   (test-name (db:test-get-testname test))
			   (run-dir   (db:test-get-rundir test)))
		    (print "  " (db:test-get-testname test) " id: " (db:test-get-id test) " " (db:test-get-item-path test))
		    (db:delete-test-records db (db:test-get-id test))
		    (if (> (string-length (db:test-get-rundir test)) 5) ;; bad heuristic but should prevent /tmp /home etc.
			(let ((fullpath (db:test-get-rundir test))) ;; "/" (db:test-get-item-path test))))
			  (set! lasttpath fullpath)
			  (print "rm -rf " fullpath)
			  (system (conc "rm -rf " fullpath))
			  (let ((cmd (conc "rmdir -p " (get-dir-up-one fullpath))))
			    (print cmd)
			    (system cmd))
			  )))
		  tests)))
		      (debug:print 1 "  " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path)
		      (db:delete-test-records db (db:test-get-id test))
		      (if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc.
			  (let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test))))
			    (set! lasttpath fullpath)
			    (debug:print 1 "rm -rf " fullpath)
			    (system (conc "rm -rf " fullpath))
			    (let* ((dirs-count (+ 1 (length keys)(length (string-split item-path "/"))))
				   (dir-to-rem (get-dir-up-n fullpath dirs-count))
				   (remainingd (string-substitute (regexp (conc "^" dir-to-rem "/")) "" fullpath))
				   (cmd (conc "cd " dir-to-rem "; rmdir -p " remainingd )))
			      (if (file-exists? fullpath)
				  (begin
				    (debug:print 1 cmd)
				    (system cmd)))
			      ))
			    )))
		    tests)))
	   (let ((remtests (db-get-tests-for-run db (db:get-value-by-header run header "id"))))
	     (if (null? remtests) ;; no more tests remaining
		 (let* ((dparts  (string-split lasttpath "/"))
			(runpath (conc "/" (string-intersperse 
					    (take dparts (- (length dparts) 1))
					    "/"))))
		   (print "Removing run: " runkey " " (db:get-value-by-header run header "runname"))
		   (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname"))
		   (db:delete-run db run-id)
		   ;; need to figure out the path to the run dir and remove it if empty
		;;    (if (null? (glob (conc runpath "/*")))
		;;        (begin
		;; 	 (print "Removing run dir " runpath)
		;; 	 (system (conc "rmdir -p " runpath))))
		   )))
		 )))
		   ;;    (if (null? (glob (conc runpath "/*")))
		   ;;        (begin
		   ;; 	 (debug:print 1 "Removing run dir " runpath)
		   ;; 	 (system (conc "rmdir -p " runpath))))
		   ))))
	 ))
     runs)))

# run some tests

MEGATEST=$(shell realpath ../megatest)

runall :
	cd ../;make 
	$(MEGATEST) -keepgoing -runall :sysname ubuntu :fsname nfs :datapath none :runname `date +%GWW%V.%u` -m "This is a comment specific to a run"
	$(MEGATEST) -keepgoing -runall :sysname ubuntu :fsname nfs :datapath none :runname `date +%GWW%V.%u` -m "This is a comment specific to a run" -v

test :
	cd ../;make test
	make runall

dashboard :
	cd ../;make dashboard

# These are set before all tests, override them 
# in the testconfig [pre-launch-env-overrides] section
[env-override]
SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs
TESTVAR [system realpath .]
DEADVAR [system ls]
# XTERM   [system xterm]
# RUNDEAD [system exit 56]

## disks are:
## name host:/path/to/area
## -or-
## name /path/to/area
[disks]
1 /tmp

(test "Get best dir" #t (let ((bestdir (get-best-disk conffile)))
			      (or (equal? "./"   bestdir)
				  (equal? "/tmp" bestdir))))

;; db
(define row    (vector "a" "b" "c" "blah"))
(define header (list "col1" "col2" "col3" "col4"))
(test "Get row by header" "blah" (db-get-value-by-header row header "col4"))
(test "Get row by header" "blah" (db:get-value-by-header row header "col4"))

;; (define *toppath* "tests")
(define *db* #f)
(test "setup for run" #t (begin (setup-for-run)
				(string? (getenv "MT_RUN_AREA_HOME"))))
(test "open-db" #t (begin
		     (set! *db* (open-db))

	  (list "pass" "fail" "n/a"))

(test "write env files" "nada.csh" (begin
                                      (save-environment-as-files "nada")
                                      (and (file-exists? "nada.sh")
    			                 (file-exists? "nada.csh"))))

(test "get all legal tests" (list "runfirst" "sqlitespeed") (sort (get-all-legal-tests) string<=?))
(test "get all legal tests" (list "runfirst" "runwithfirst" "singletest" "singletest2" "sqlitespeed") (sort (get-all-legal-tests) string<=?))

(test "register-test, test info" "NOT_STARTED"
      (begin
	(register-test *db* 1 "nada" "")
	(test:get-state (runs:get-test-info *db* 1 "nada" ""))))
	(test:get-state (db:get-test-info *db* 1 "nada" ""))))

(test "get-keys" "sysname" (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0)))))))

(define remargs (args:get-args
		 '("bar" "foo" ":runname" "bob" ":sysname" "ubuntu" ":fsname" "nfs" ":datapath" "blah/foo" "nada")
		 (list ":runname" ":state" ":status")
		 (list "-h")

(test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz))))
				       (result   (get-environment-variable "NADAFOO")))
				    (alist->env-vars prevvals)
				    result))

(test "env restored" "1234" (get-environment-variable "BLAHFOO"))

				    

(test "Items assoc" "Elephant" (cadar (cadr (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall"))))))
(set! *verbosity* 6)
(test "Items assoc" '()(item-assoc->item-list '(("a" "a b c d")("b" "c d e")("c" "")("d"))))
(set! *verbosity* -1)
(test "Items assoc empty items" '()   (item-assoc->item-list '(("A"))))
(set! *verbosity* 1)
(test "Items table" "SEASON" (caadar (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter")))))
(test "Items table empty items I" '() (item-table->item-list '(("A"))))
(test "Items table empty items II" '() (item-table->item-list '(("A" ""))))

[setup]
runscript runscript.rb

[requirements]
waiton    runfirst

[items]
MANYITEMS [system (env > envfile.txt;echo aa ab ac ad ae af ag ah ai aj ak al am an ao ap aq ar as at au)]
# BORKED