Megatest

  (or (configf:lookup (megatest:area-configdat area-dat) "setup" "testsuite" )
       (pathname-file (megatest:area-path      area-dat))))

;;======================================================================
;; E X I T   H A N D L I N G
;;======================================================================

(define (common:legacy-sync-recommended)
  (or (args:get-arg "-runtests")
      (args:get-arg "-server")
      (args:get-arg "-set-run-status")
      (args:get-arg "-remove-runs")
      (args:get-arg "-get-run-status")
      ))

(define (common:legacy-sync-required)
  (configf:lookup *configdat* "setup" "megatest-db"))

(define (std-exit-procedure)
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f
		       (begin
			 (set! *time-to-exit* #t)
			 #t)))
         (configdat (megatest:area-configdat area-dat))
	 (run-ids   (hash-table-keys *db-local-sync*)))
    (debug:print-info 4 "starting exit process, finalizing databases.")

					  (sqlite3:interrupt! db)
					  (sqlite3:finalize! db #t)
					  (vector-set! *task-db* 0 #f)))))) "Cleanup db exit thread"))
	  (th2 (make-thread (lambda ()
			      (debug:print 4 "Attempting clean exit. Please be patient and wait a few seconds...")
			      (if no-hurry
				  (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff
				  (thread-sleep! 2))
			      (debug:print 4 " ... done")
			      )
			    "clean exit")))
      (thread-start! th1)
      (thread-start! th2)
      (thread-join! th1))))

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

;; R U N   C O N T R O L
;;======================================================================

;; General displayer
;;
(define (dashboard:area-display data adat window-id)
  (let* ((view-matrix     (iup:matrix
			   ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f))
			   #:expand "YES"
			   ;; #:fittosize "YES"
			   #:scrollbar "YES"
			   #:numcol 100
			   #:numlin 100
			   #:numcol-visible 3
			   #:numlin-visible 3

       view-matrix)))))

;; Browse and control a single run
;;
(define (runcontrol window-id)
  (iup:hbox))

;; NB// Wierd conflict error here
;;
;;		     (let* ((runs-dat     (db:get-runs-by-patt db *keys* "%" #f #f #f #f))

;;======================================================================
;; A R E A S
;;======================================================================

(define (dashboard:init-area data area-name apath)
  (let* ((mtconffile  (conc area-name "/megatest.config"))
	 (mtconf      (read-config mtconffile (make-hash-table) #f)) ;; megatest.config

    (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";"))))

;; open an sql database inside a file lock
;;
;; returns: db existed-prior-to-opening
;;
(define (db:lock-create-open fname initproc area-dat)
  ;; (if (file-exists? fname)
  ;;     (let ((db (sqlite3:open-database fname)))
  ;;       (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
	(db:set-sync db area-dat) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
  ;;       db)
  (let* ((parent-dir   (pathname-directory fname))
	 (dir-writable (file-write-access? parent-dir))

	 (file-exists  (file-exists? fname))
	 (file-write   (if file-exists
			   (file-write-access? fname)
			   dir-writable )))
    (if file-write ;; dir-writable
	(let (;; (lock    (obtain-dot-lock fname 1 5 10))
	      (db      (sqlite3:open-database fname)))
	  (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
	      (db:set-sync db area-dat) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	  (if (not file-exists)(initproc db))
	  ;; (release-dot-lock fname)
	  db)
	(begin
	  (debug:print 2 "WARNING: opening db in non-writable dir " fname)
	  (sqlite3:open-database fname))))) ;; )

;; This routine creates the db. It is only called if the db is not already opened
;; 
(define (db:open-rundb dbstruct area-dat run-id #!key (attemptnum 0)(do-not-open #f)) ;;  (conc toppath "/megatest.db") (car configinfo)))
  (let* ((local  (dbr:dbstruct-get-local dbstruct))
	 (rdb    (if local
		     (dbr:dbstruct-get-localdb dbstruct run-id)

		 (inmem        (if local #f (db:open-inmem-db)))
		 (refdb        (if local #f (db:open-inmem-db)))
		 (db           (db:lock-create-open dbpath ;; this is the database physically on disk
						    (lambda (db)
						      (handle-exceptions
						       exn
						       (begin
							 ;; (release-dot-lock dbpath)
							 (if (> attemptnum 2)
							     (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath)
							   (db:open-rundb dbstruct area-dat run-id attemptnum (+ attemptnum 1))))
						       (db:initialize-run-id-db db)
						       (sqlite3:execute 
							db
							"INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');"

	   '("description"    #f)
	   '("reviewed"       #f)
	   '("iterated"       #f)
	   '("avg_runtime"    #f)
	   '("avg_disk"       #f)
	   '("tags"           #f)
	   '("jobgroup"       #f)))))

;; use bunch of Unix commands to try to break the lock and recreate the db
;;
(define (db:move-and-recreate-db dbdat)
  (let* ((dbpath   (db:dbdat-get-path        dbdat))
	 (dbdir    (pathname-directory       dbpath))
	 (fname    (pathname-strip-directory dbpath))
	 (fnamejnl (conc fname "-journal"))
	 (tmpname  (conc fname "." (current-process-id)))
	 (tmpjnl   (conc fnamejnl "." (current-process-id))))
    (debug:print 0 "ERROR: " fname " appears corrupted. Making backup \"old/" fname "\"")
    (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname))
    (system (conc "rm -f " dbpath))
    (if (file-exists? fnamejnl)
	(begin
	  (debug:print 0 "ERROR: " fnamejnl " found, moving it to old dir as " tmpjnl)
	  (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl))
	  (system (conc "rm -f " dbdir "/" fnamejnl))))
    ;; attempt to recreate database
    (system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname))))
    
;; return #f to indicate the dbdat should be closed/reopened
;; else return dbdat
;;
(define (db:repair-db dbdat #!key (numtries 1))
  (let* ((dbpath   (db:dbdat-get-path        dbdat))
	 (dbdir    (pathname-directory       dbpath))
	 (fname    (pathname-strip-directory dbpath)))
    (debug:print-info 0 "Checking db " dbpath " for errors.")
    (cond
     ((not (file-write-access? dbdir))
      (debug:print 0 "WARNING: can't write to " dbdir ", can't fix " fname)
      #f)

     ;; handle special cases, megatest.db and monitor.db
     ;; 
     ;;  NOPE: apply this same approach to all db files
     ;;
     (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed
      (handle-exceptions
       exn
       (begin
	 ;; (db:move-and-recreate-db dbdat)
	 (if (> numtries 0)
	     (db:repair-db dbdat numtries: (- numtries 1))
	     #f)
	 (debug:print 0 "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.")
	 (debug:print 0
		      "   check the following:\n"
		      "      1. full directories, look in ~/ /tmp and " dbdir "\n"
		      "      2. write access to " dbdir "\n\n"
		      "   if the automatic recovery failed you may be able to recover data by doing \"" 
		      (if (member fname '("megatest.db" "monitor.db"))
			  "megatest -cleanup-db"
			  "megatest -import-megatest.db;megatest -cleanup-db")
		      "\"\n")
	 (exit) ;; we can not safely continue when a db was corrupted - even if fixed.
	 )
       ;; test read/write access to the database
       (let ((db (sqlite3:open-database dbpath)))
	 (cond
	  ((equal? fname "megatest.db")
	   (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';"))
	  ((equal? fname "main.db")
	   (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';"))
	  ((string-match "\\d.db" fname)
	   (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';"))
	  ((equal? fname "monitor.db")
	   (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
	  (else
	   (sqlite3:execute db "vacuum;")))
	 
	 (finalize! db)
	 #t))))))
    
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;; db's are dbdat's
;;
(define (db:sync-tables area-dat tbls fromdb todb . slave-dbs)
  (mutex-lock! *db-sync-mutex*)
  (handle-exceptions
   exn
   (begin
     (mutex-unlock! *db-sync-mutex*)
     (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
     (print-call-chain (current-error-port))
     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
     (print "exn=" (condition->list exn))
     (debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
     (debug:print 0 " src db:  " (db:dbdat-get-path fromdb))
     (for-each (lambda (dbdat)
		 (let ((dbpath (db:dbdat-get-path dbdat)))
		   (debug:print 0 " dbpath:  " dbpath)
		   (if (not (db:repair-db dbdat))
		       (begin
			 (debug:print 0 "ERROR: Failed to rebuild " dbpath ", exiting now.")
			 (exit)))))
	       (cons todb slave-dbs))
     
     0)
;;      (if *server-run* ;; we are inside a server, throw a sync-failed error
;; 	 (signal (make-composite-condition
;; 		 (make-property-condition 'sync-failed 'message "db:sync-tables failed in a server context.")))
;; 	 0)) ;; return zero for num synced

	 ;; (set! *time-to-exit* #t) ;; let watch dog know that it is time to die.
	 ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
	 ;; (portlogger:open-run-close portlogger:set-port port "released")
	 ;; (exit 1)))
   (cond
    ((not fromdb) (debug:print 3 "WARNING: db:sync-tables called with fromdb missing") -1)

		   (lambda (a . x)
		     (set! res (cons (apply vector a x) res)))
		   db
		   qrystr
		   )))
    (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
    (vector header res)))

(define (db:get-changed-run-ids since-time)
  (let* ((dbdir      (db:dbfile-path #f)) ;; (configf:lookup *configdat* "setup" "dbdir"))
	 (alldbs     (glob (conc dbdir "/[0-9]*.db")))
	 (changed    (filter (lambda (dbfile)
			       (> (file-modification-time dbfile) since-time))
			     alldbs)))
    (delete-duplicates
     (map (lambda (dbfile)
	    (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile)))
	      (if res
		  (string->number (cadr res))
		  (begin
		    (debug:print 2 "WARNING: Failed to process " dbfile " for run-id")
		    0))))
	  changed))))

;; db: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-rows runinfo))
;;  to extract info from the structure returned

	 (runs-info    '()))
    ;; First get all the runname/run-ids
    (db:delay-if-busy dbdat area-dat)
    (sqlite3:for-each-row
     (lambda (run-id runname)
       (set! runs-info (cons (list run-id runname) runs-info)))
     db
     "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats
    ;; for each run get stats data
    (for-each
     (lambda (run-info)
       ;; get the net state/status counts for this run
       (let* ((run-id   (car  run-info))
	      (run-name (cadr run-info)))
	 (db:with-db

;; db: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-rows runinfo))
;;  to extract info from the structure returned
;;
(define (db:get-runs-by-patt dbstruct area-dat keys runnamepatt targpatt offset limit fields) ;; test-name)
;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields) ;; test-name)
  (let* ((tmp      (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time"))))
	 (keystr   (car tmp))
	 (header   (cadr tmp))
	 (res     '())
	 (key-patt "")
	 (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
	 (qry-str  #f)
	 (keyvals  (if targpatt (keys:target->keyval keys targpatt) '())))

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1,1101 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.6015)

  -list-db-targets        : list the target combinations used in the db
  -show-config            : dump the internal representation of the megatest.config file
  -show-runconfig         : dump the internal representation of the runconfigs.config file
  -dumpmode json          : dump in json format instead of sexpr
  -show-cmdinfo           : dump the command info for a test (run in test environment)
  -section sectionName
  -var varName            : for config and runconfig lookup value for sectionName varName
  -since N                : get list of runs changed since time N (Unix seconds)
  -fields fieldspec       : fields to include in json dump; runs:id,runame+tests:testname+steps

Misc 
  -start-dir path         : switch to this directory before running megatest
  -rebuild-db             : bring the database schema up to date
  -cleanup-db             : remove any orphan records, vacuum the db
  -import-megatest.db     : migrate a database from v1.55 series to v1.60 series
  -sync-to-megatest.db    : migrate data back to megatest.db

			"-dumpmode"
			"-run-id"
			"-ping"
			"-refdb2dat"
			"-o"
			"-log"
			"-archive"
			"-since"
			"-fields"
			) 
		 (list  "-h" "-help" "--help"
			"-version"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-show-keys"

  (make-thread 
   (lambda ()
     (thread-sleep! 0.05) ;; delay for startup
     ;; the query to get megatest-db setting might not work, forcing it to be default on. Use "no" to turn off
     (let ((legacy-sync (configf:lookup (megatest:area-configdat *area-dat*) "setup" "megatest-db"))
	   (debug-mode  (debug:debug-mode 1))
	   (last-time   (current-seconds)))
       (if (common:legacy-sync-recommended)





	   (let loop ()
	     ;; sync for filesystem local db writes
	     ;;
	     (let ((start-time      (current-seconds))
		   (servers-started (make-hash-table)))
	       (for-each 
		(lambda (run-id)

;;======================================================================
;; Weird special calls that need to run *after* the server has started?
;;======================================================================

(if (args:get-arg "-list-targets")
    (let ((targets (common:get-runconfig-targets)))
      (print "Found "(length targets) " targets")
      (case (string->symbol (or (args:get-arg "-dumpmode") "alist"))
	((alist)
	 (for-each (lambda (x)
		     ;; (print "[" x "]"))
		     (print x))
		   targets))
	((json)
	 (json-write targets))
	(else
	 (debug:print 0 "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
      (set! *didsomething* #t)))

(define (full-runconfigs-read area-dat)
  (let* ((toppath  (megatest:area-path area-dat))
	 (keys     (rmt:get-keys))
	 (target   (common:args-get-target))
	 (key-vals (if target (keys:target->keyval keys target) #f))

	 ((and (args:get-arg "-section")
	       (args:get-arg "-var"))
	  (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
	    (if val (print val))))
	 ((not (args:get-arg "-dumpmode"))
	  (pp (hash-table->alist data)))
	 ((string=? (args:get-arg "-dumpmode") "json")
	  (json-write data))
	 (else
	  (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
	(set! *didsomething* #t))
      (pop-directory)))

(if (args:get-arg "-show-config")
    (let ((tl   (launch:setup-for-run *area-dat*))

	(json-write data))
       (else
	(debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
      (set! *didsomething* #t)
      (pop-directory)))

(if (args:get-arg "-show-cmdinfo")
    (if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
	(let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO")))))
	  (if (equal? (args:get-arg "-dumpmode") "json")
	      (json-write data)
	      (pp data))
	  (set! *didsomething* #t))
	(debug:print-info 0 "environment variable MT_CMDINFO is not set")))

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

		   (print (rmt:get-run-status run-id))
		   )))))
     *area-dat*))

;;======================================================================
;; Query runs
;;======================================================================

;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps
;;
;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps")
;;         => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps"))
;;
;;   NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment")
;;         and so alist-ref will yield what you expect
;;
(define (extract-fields-constraints fields-spec)
  (map (lambda (table-spec) ;; runs:id,target,runname
	 (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname")
	   (if (> (length dat) 1)
	       (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname"
	       dat)))
       (string-split fields-spec "+")))

(define (get-value-by-fieldname datavec test-field-index fieldname)
  (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
    (if indx
	(if (>= indx (vector-length datavec))
	    #f ;; index to high, should raise an error I suppose
	    (vector-ref datavec indx))
	#f)))

;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (launch:setup-for-run *area-dat*)
	(let* ((dbstruct (make-dbr:dbstruct path: (megatest:area-path *area-dat*) local: #t))
	       (runpatt     (args:get-arg "-list-runs"))
	       (testpatt    (if (args:get-arg "-testpatt") 
			        (args:get-arg "-testpatt") 
			        "%"))
	       (keys        (db:get-keys dbstruct))
	       ;; (runsda   t  (db:get-runs dbstruct runpatt #f #f '()))
	       (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target)
			           	 #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment")))
	       (runstmp     (db:get-rows runsdat))
	       (header      (db:get-header runsdat))
	       (runs        (if (and (not (null? runstmp))
				     (args:get-arg "-since"))
				(let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
				  (let loop ((hed (car runstmp))
					     (tal (cdr runstmp))
					     (res '()))
				    (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids)
						       (cons hed res)
						       res)))
				      (if (null? tal)
					  (reverse new-res)
					  (loop (car tal)(cdr tal) new-res)))))
				runstmp))
	       (db-targets  (args:get-arg "-list-db-targets"))
	       (seen        (make-hash-table))
	       (dmode       (let ((d (args:get-arg "-dumpmode")))
			      (if d (string->symbol d) #f)))
	       (data        (make-hash-table))
	       (fields-spec (if (args:get-arg "-fields")
				(extract-fields-constraints (args:get-arg "-fields"))
				(list (list "runs"  "id" "target"   "runname")
				      (cons "tests"  db:test-record-fields) ;; "id" "testname" "test_path")
				      (list "steps" "id" "stepname"))))
	       (runs-spec   (let ((r (alist-ref "runs"  fields-spec equal?)))
			      (if (and r (not (null? r))) r (list "id"))))
	       (tests-spec  (let ((t (alist-ref "tests" fields-spec equal?)))
			      (if (and t (null? t)) ;; all fields
				  db:test-record-fields
				  t)))
	       (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id"))))
	       (steps-spec  (alist-ref "steps" fields-spec equal?))
	       (test-field-index (make-hash-table)))
	  (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
	      (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
		(if (null? invalid-tests-spec)
		    ;; generate the lookup map test-field-name => index-number
		    (let loop ((hed (car adj-tests-spec))
			       (tal (cdr adj-tests-spec))
			       (idx 0))
		      (hash-table-set! test-field-index hed idx)
		      (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
		    (begin
		      (debug:print 0 "ERROR: Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
		      (exit)))))

	  ;; Each run
	  (for-each 
	   (lambda (run)
	     (let ((targetstr (string-intersperse (map (lambda (x)
							 (db:get-value-by-header run header x))
						       keys) "/")))
	       (if db-targets
		   (if (not (hash-table-ref/default seen targetstr #f))
		       (begin
			 (hash-table-set! seen targetstr #t)
			 ;; (print "[" targetstr "]"))))
			 (if (not dmode)(print targetstr))))
		   (let* ((run-id  (db:get-value-by-header run header "id"))
			  (runname (db:get-value-by-header run header "runname")) 
			  (tests   (if tests-spec
				       (rmt:get-tests-for-run run-id testpatt '() '() #f #f #f 'testname 'asc 
							     ;; use qryvals if test-spec provided
							     (if tests-spec
								 (string-intersperse adj-tests-spec ",")
								 ;; db:test-record-fields
								 #f))
				       '())))
		     (case dmode
		       ((json)
			(if runs-spec
			    (for-each 
			     (lambda (field-name)
			       (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name))
			     runs-spec)))
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "status")     targetstr runname "meta" "status"     )
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "state")      targetstr runname "meta" "state"      )
			;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id"))  targetstr runname "meta" "id"         )
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" )
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment")    targetstr runname "meta" "comment"    )
			;; ;; add last entry twice - seems to be a bug in hierhash?
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment")    targetstr runname "meta" "comment"    )
		       (else
			(print "Run: " targetstr "/" runname 
			       " status: " (db:get-value-by-header run header "state")
			       " run-id: " run-id ", number tests: " (length tests))))
		     (for-each 
		      (lambda (test)
		      	(handle-exceptions
			 exn
			 (begin
			   (debug:print 0 "ERROR: Bad data in test record? " test)
			   (print "exn=" (condition->list exn))
			   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
			   (print-call-chain (current-error-port)))
			 (let* ((test-id      (get-value-by-fieldname test test-field-index "id"       )) ;; (db:test-get-id         test))
				(testname     (get-value-by-fieldname test test-field-index "testname" )) ;; (db:test-get-testname   test))
				(itempath     (get-value-by-fieldname test test-field-index "item_path")) ;; (db:test-get-item-path  test))
				(comment      (get-value-by-fieldname test test-field-index "comment"  )) ;; (db:test-get-comment    test))
				(tstate       (get-value-by-fieldname test test-field-index "state"    )) ;; (db:test-get-state      test))
				(tstatus      (get-value-by-fieldname test test-field-index "status"   )) ;; (db:test-get-status     test))
				(event-time   (get-value-by-fieldname test test-field-index "event_time")) ;; (db:test-get-event_time test))
				(rundir       (get-value-by-fieldname test test-field-index "rundir"    )) ;; (db:test-get-rundir     test))
				(final_logf   (get-value-by-fieldname test test-field-index "final_logf")) ;; (db:test-get-final_logf test))
				(run_duration (get-value-by-fieldname test test-field-index "run_duration")) ;; (db:test-get-run_duration test))
				(fullname     (conc testname
						    (if (equal? itempath "")
							"" 
							(conc "(" itempath ")")))))



			   (case dmode
			     ((json)
			      (if tests-spec
				  (for-each
				   (lambda (field-name)
				     (mutils:hierhash-set! data  (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name))
				   tests-spec)))
			     ;; ;; (mutils:hierhash-set! data  fullname   targetstr runname "data" (conc test-id) "tname"     )
			     ;;  (mutils:hierhash-set! data  testname   targetstr runname "data" (conc test-id) "testname"  )
			     ;;  (mutils:hierhash-set! data  itempath   targetstr runname "data" (conc test-id) "itempath"  )
			     ;;  (mutils:hierhash-set! data  comment    targetstr runname "data" (conc test-id) "comment"   )
			     ;;  (mutils:hierhash-set! data  tstate     targetstr runname "data" (conc test-id) "state"     )
			     ;;  (mutils:hierhash-set! data  tstatus    targetstr runname "data" (conc test-id) "status"    )
			     ;;  (mutils:hierhash-set! data  rundir     targetstr runname "data" (conc test-id) "rundir"    )
			     ;;  (mutils:hierhash-set! data  final_logf targetstr runname "data" (conc test-id) "final_logf")
			     ;;  (mutils:hierhash-set! data  run_duration targetstr runname "data" (conc test-id) "run_duration")
			     ;;  (mutils:hierhash-set! data  event-time targetstr runname "data" (conc test-id) "event_time")
			     ;;  ;; add last entry twice - seems to be a bug in hierhash?
			     ;;  (mutils:hierhash-set! data  event-time targetstr runname "data" (conc test-id) "event_time")
			     ;;  )
			     (else
			      (format #t
				      "  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
				      fullname
				      tstate
				      tstatus
				      (db:test-get-run_duration test)

						 (tdb:step-get-event_time step)))
				       steps)))))))))
		      tests)))))
	   runs)
	  (if (eq? dmode 'json)(json-write data))
	  (set! *didsomething* #t))))

;; Don't think I need this. Incorporated into -list-runs instead
;;
;; (if (and (args:get-arg "-since")
;; 	 (launch:setup-for-run))
;;     (let* ((since-time (string->number (args:get-arg "-since")))
;; 	   (run-ids    (db:get-changed-run-ids since-time)))
;;       ;; (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
;;       (print (sort run-ids <))
;;       (set! *didsomething* #t)))
      
      
;;======================================================================
;; full run
;;======================================================================

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

;; 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-rows runinfo))
;;  to extract info from the structure returned
;;
(define (mt:get-runs-by-patt keys runnamepatt targpatt)
  (let loop ((runsdat  (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f))
	     (res      '())
	     (offset   0)
	     (limit    500))
    ;; (print "runsdat: " runsdat)
    (let* ((header    (vector-ref runsdat 0))
	   (runslst   (vector-ref runsdat 1))
	   (full-list (append res runslst))
	   (have-more (eq? (length runslst) limit)))
      ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more)
      (if have-more 
	  (let ((new-offset (+ offset limit))
		(next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f)))
	    (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.")
	    (debug:print-info 0 "next-batch: " next-batch)
	    (loop next-batch
		  full-list
		  new-offset
		  limit))
	 (vector header full-list)))))

(define (rmt:set-run-status run-id run-status area-dat #!key (msg #f))
  (rmt:send-receive 'set-run-status #f (list run-id run-status msg) area-dat))

(define (rmt:update-run-event_time run-id area-dat)
  (rmt:send-receive 'update-run-event_time #f (list run-id) area-dat))

(define (rmt:get-runs-by-patt  keys runnamepatt targpatt offset limit area-dat fields)
  (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit) area-dat))

(define (rmt:find-and-mark-incomplete run-id ovr-deadtime area-dat)
  (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime) area-dat)
      (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime) area-dat)))

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

(define (tests:check-waiver-eligibility testdat prev-testdat area-dat)
  (let* ((test-registry (make-hash-table))
	 (testconfig  (tests:get-testconfig (db:test-get-testname testdat) test-registry #f area-dat))
	 (test-rundir ;; (sdb:qry 'passstr 
	  (db:test-get-rundir testdat)) ;; )
	 (prev-rundir ;; (sdb:qry 'passstr 
	  (db:test-get-rundir prev-testdat)) ;; )
	 (waivers     (if testconfig (configf:section-vars testconfig "waivers") '()))
	 (waiver-rx   (regexp "^(\\S+)\\s+(.*)$"))
	 (diff-rule   "diff %file1% %file2%")
	 (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html"))
    (if (not (file-exists? test-rundir))
	(begin
	  (debug:print 0 "ERROR: test run directory is gone, cannot propagate waiver")
	  #f)

# turn off faststart, put monitor.db in MT_RUN_AREA_HOME/db
# and set the dbdir to /var/tmp/$USER/mt_db to enable keeping
# the raw db in /var/tmp/$USER
#
faststart  no
monitordir #{getenv MT_RUN_AREA_HOME}/db
dbdir      #{getenv MT_RUN_AREA_HOME}/db

# sync more aggressively to megatest-db
megatest-db yes

# Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding
# this may save a few milliseconds on launching tests
# launchwait no
waivercommentpatt ^WW\d+ [a-z].*
incomplete-timeout 1

state start end 0 1 - 2
status pass fail n/a 0 1 running - 2

# These are set before all tests, override them 
# in the testconfig [pre-launch-env-overrides] section
[env-override]


ALL_TOPLEVEL_TESTS          exit_0 exit_1  ez_exit2_fail  ez_fail        ez_pass              ezlog_fail \
       ezlog_fail_then_pass ezlog_pass     ezlog_warn     lineitem_fail  lineitem_pass        logpro_required_fail \
       manual_example       neverrun       priority_1     priority_10    priority_10_waiton_1 \
       priority_3           priority_4     priority_5     priority_6     priority_7           priority_8 \
       priority_9           runfirst       singletest     singletest2    sqlitespeed          test_mt_vars \
       ez_fail_quick        test1          test2

# This variable is honored by the loadrunner script. The value is in percent
MAX_ALLOWED_LOAD 200

# MT_XTERM_CMD overrides the terminal command
# MT_XTERM_CMD xterm -bg lightgreen -fg black

SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs

		     ("ez_pass"		        1  20)
		     ("lineitem_pass"	        1  20)
		     ("priority_1"	        1  20)
		     ("priority_10"	        1  20)
		     ("priority_10_waiton_1"    1  20)
		     ("priority_3"	        1  20)
		     ("priority_4"	        1  20)
		     ;; ("priority_5"	        1  20)
		     ("priority_6"	        1  20)
;;		     ("priority_7"	        1  20)
		     ("priority_8"	        1  20)
		     ("priority_9"	        1  20)
		     ("runfirst"	        7  20)
		     ("singletest"	        1  20)
		     ("singletest2"	        1  20)
		     ("special"		        1  20)
		     ("sqlitespeed"	       10  20)

		     ("ezlog_fail"	        1  20)
		     ("lineitem_fail"	        1  20)
		     ("logpro_required_fail"    1  20)
		     ("manual_example"	        1  20)
		     ("neverrun"	        1  20)))
		     
(define warn-specs   '(("ezlog_warn"	        1  20)))

(define nost-specs   '(("wait_no_items1"        1  20)
		       ("wait_no_items2"        1  20)
		       ("wait_no_items3"        1  20)
		       ("wait_no_items4"        1  20)
		       ;; ("no_items"              1  20)
		       ))

(define (check-one-test estate estatus testname count runtime)
   (let* ((rxe      (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s")))
	  (msg1     (conc testname " expecting count of " count))
	  (msg2     (conc testname " expecting runtime less than " runtime)))
     (expect:required in logbody = count msg1 rxe)
     ;;(expect:value    in logbody count < msg2 rxe)
     ))

;; Special cases
;;
(expect:ignore   in logbody >= 0  "db_sync test might not have run"  #/Test: db_sync/)
(expect:ignore   in logbody >= 0  "all_toplevel may not yet be done" #/Test: all_toplevel/)
(expect:error    in logbody =  0  "tests left in RUNNING state"      #/State: RUNNING/)
(expect:required in logbody =  1  "priority_2 is KILLED"             #/Test: priority_2\s+State: KILLED\s+Status: KILLED/)
(expect:required in logbody =  1  "priority_5 is either PASS or SKIP" #/Test: priority_5\s+State: COMPLETED\s+Status: (SKIP|PASS)/)
(expect:required in logbody =  1  "priority_7 is either PASS or SKIP" #/Test: priority_7\s+State: COMPLETED\s+Status: (SKIP|PASS)/)
(expect:required in logbody =  1  "testxz has 1 NOT_STARTED test"    #/Test: testxz\s+State: NOT_STARTED/)
(expect:required in logbody =  1  "no items"                         #/Test: no_items\s+State: NOT_STARTED\s+Status: ZERO_ITEMS/)
(expect:warning  in logbody =  1  "dynamic waiton"                   #/Test: dynamic_waiton/)
(expect:required in logbody = 29  "blocktestxz has 29 tests"         #/Test: blocktestxz/)

;; General cases
;;
(for-each 
 (lambda (testdat)
   (apply check-one-test "COMPLETED" "PASS" testdat))

(for-each 
 (lambda (testdat)
   (apply check-one-test "COMPLETED" "WARN" testdat))
 warn-specs)

(for-each 
 (lambda (testdat)
   (apply check-one-test "NOT_STARTED" "PREQ_DISCARDED" testdat))
 nost-specs)

;; Catch all.
;;
(expect:error    in logbody = 0   "Tests not accounted for"     #/Test: /)

[ezsteps]
calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET

[requirements]
waiton  #{getenv ALL_TOPLEVEL_TESTS}






# This is a "toplevel" test, it does not require waitons to be non-FAIL to run
mode toplevel

;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com
;;  
;;   License GPL.

;; ;; define your hooks
;; (hook:first-error   "echo \"Error hook activated: #{escaped errmsg}\"")
;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"")
;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"")
;; 
;; ;; first ensure your run at least started
;; ;;
;; (trigger "Init"     #/This is a header/)
;; (trigger "InitEnd"  #/^\s*$/)
;; (section "Init" "Init" "InitEnd")
;; 
;; (trigger "Body"     #/^.*$/) ;; anything starts the body
;; ;; (trigger "EndBody"  #/This had better never match/)
;; 
;; (section "Body"     "Body" "EndBody")
;; 
;; (trigger "Blah2"    #/^begin Blah2/)
;; (trigger "Blah2End" #/^end Blah2/)
;; (section "Blah2"    "Blah2" "Blah2End")
;; 
;; (expect:required in "Init"  = 1 "Header"      #/This is a header/)
;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/)
;; (expect:value    in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/)
;; (expect:value    in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/)
;; (expect:value    in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/)
;; (expect:value    in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/)
;; (expect:value    in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/)
;; 
;; ;; Using match number
;; (expect:value    in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2)
;; 
;; ;; Comparison instead of tolerance
;; (expect:value    in "LogFileBody" 1.9 >   "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2)
;; 
;; (expect:ignore   in "Blah2" < 99 "FALSE ERROR" #/ERROR/)
;; (expect:ignore   in "Body"  < 99 "Ignore the word error in comments" #/^\/\/.*error/)
;; (expect:warning  in "Body"  = 0 "Any warning" #/WARNING/)
;; (expect:error    in "Body"  = 0 "ERROR BLAH"  (list #/ERROR/ #/error/)) ;; but disallow any other errors
;; 
;; ;(expect in "Init"  < 1 "Junk"        #/This is bogus/)

(use sql-de-lite)

(define megatest.db (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))

(define runsquery "sysname||'/'||fsname||'/'||datapath||'/'||runname||'/'||runs.state||'-'||runs.status") 
(define bigquery
  (conc 
   "SELECT " runsquery "||testname||'/'||item_path||'-'||'-'||tests.state||'-'||tests.status||'-'||runs.id AS outdat FROM runs INNER JOIN tests ON runs.id=tests.run_id WHERE runs.state NOT LIKE 'deleted' AND tests.state NOT LIKE 'deleted' AND testname NOT LIKE 'db_sync' ORDER BY outdat ASC ;"))

(print "Creating file for legacy db")
(with-output-to-file "legacy-db-dump"
  (lambda ()
    (let ((db (open-database megatest.db)))
      (query (for-each-row
	      (lambda (res)
		(print res)))
	     (sql db bigquery))
      (close-database db))))

(define main.db (conc (get-environment-variable "MT_DBDIR") "/main.db"))

(print "Creating file for current db")
(with-output-to-file "current-db-dump"
  (lambda ()
    (let* ((mdb      (open-database main.db))
	   (run-ids  (query fetch-column (sql mdb (conc "select id," runsquery " AS rq from runs ORDER BY rq ASC;"))))
	   (dbdir    (get-environment-variable "MT_DBDIR")))
      (for-each
       (lambda (rid)
	 (let ((dbfile (conc dbdir "/" rid ".db")))
	   (if (file-exists? dbfile)
	       (begin
		 (exec (sql mdb (conc "ATTACH DATABASE '" dbfile "' AS testsdb;")))
		 (query (for-each-row
			 (lambda (res)
			   (print res)))
			(sql mdb bigquery))
		 (exec (sql mdb "DETACH DATABASE testsdb;")))
	       (print "ERROR: No file " dbfile " found"))))
       run-ids)
      (close-database mdb))))
	 
      

(db:dbfile-path #f)

;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com
;;  
;;   License GPL.

;; ;; define your hooks
;; (hook:first-error   "echo \"Error hook activated: #{escaped errmsg}\"")
;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"")
;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"")
;; 
;; ;; first ensure your run at least started
;; ;;
;; (trigger "Init"     #/This is a header/)
;; (trigger "InitEnd"  #/^\s*$/)
;; (section "Init" "Init" "InitEnd")
;; 
;; (trigger "Body"     #/^.*$/) ;; anything starts the body
;; ;; (trigger "EndBody"  #/This had better never match/)
;; 
;; (section "Body"     "Body" "EndBody")
;; 
;; (trigger "Blah2"    #/^begin Blah2/)
;; (trigger "Blah2End" #/^end Blah2/)
;; (section "Blah2"    "Blah2" "Blah2End")
;; 
;; (expect:required in "Init"  = 1 "Header"      #/This is a header/)
;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/)
;; (expect:value    in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/)
;; (expect:value    in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/)
;; (expect:value    in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/)
;; (expect:value    in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/)
;; (expect:value    in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/)
;; 
;; ;; Using match number
;; (expect:value    in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2)
;; 
;; ;; Comparison instead of tolerance
;; (expect:value    in "LogFileBody" 1.9 >   "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2)
;; 
;; (expect:ignore   in "Blah2" < 99 "FALSE ERROR" #/ERROR/)
;; (expect:ignore   in "Body"  < 99 "Ignore the word error in comments" #/^\/\/.*error/)
;; (expect:warning  in "Body"  = 0 "Any warning" #/WARNING/)
;; (expect:error    in "Body"  = 0 "ERROR BLAH"  (list #/ERROR/ #/error/)) ;; but disallow any other errors
;; 
;; ;(expect in "Init"  < 1 "Junk"        #/This is bogus/)

(expect:error    in "LogFileBody" = 0 "Any diff is failure" #/.+/)

[pre-launch-env-vars]

MT_DBDIR #{scheme (db:dbfile-path #f)}

[ezsteps]
calcresults csi -b dbdelta.scm
showdiff    diff  current-db-dump legacy-db-dump

[requirements]
waiton  #{getenv ALL_TOPLEVEL_TESTS}

# This is a "toplevel" test, it does not require waitons to be non-FAIL to run
mode toplevel