Megatest

	  (apply print params)
	  (if *logging* (apply db:log-event params))))))

(define (debug:print-info n . params)
  (if (debug:debug-mode n)
      (with-output-to-port (current-error-port)
	(lambda ()
	  (let ((res (format#format #f "INFO:~2d ~a" n (apply conc params))))
	    (print res)
	    (if *logging* (db:log-event res)))))))

;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
  (if (or (number? val)(string? val)) val ""))

;;======================================================================
;; Database access
;;======================================================================

(require-extension (srfi 18) extras tcp rpc)
(import (prefix rpc rpc:))

(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml)
(import (prefix sqlite3 sqlite3:))

(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))

		     #f))))
    (if val
	(begin
	  (debug:print-info 11 "db:set-sync, setting pragma synchronous to " val)
	  (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';"))))))

(define (open-db) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))

  (let* ((dbpath    (conc *toppath* "/megatest.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
	 (handler   (make-busy-timeout (if (args:get-arg "-override-timeout")
					   (string->number (args:get-arg "-override-timeout"))
					   136000)))) ;; 136000))) ;; 136000 = 2.2 minutes
    (debug:print-info 11 "open-db, dbpath=" dbpath)
    (sqlite3:set-busy-handler! db handler)
    (if (not dbexists)
	(db:initialize db))
    (db:set-sync db)
    db))

;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling  proc idb . params)
  (debug:print-info 11 "open-run-close-no-exception-handling START, idb=" idb ", params=" params)
  (let* ((db   (if idb idb (open-db)))
	 (res #f))
    (set! res (apply proc db params))
    (if (not idb)(sqlite3:finalize! db))
    (debug:print-info 11 "open-run-close-no-exception-handling END" )
    res))

    (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
						 (if throttle throttle 0.01)))
			    2))
    (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
	(begin
	  (debug:print-info 4 "launch throttle factor=" *global-delta*)
	  (set! *last-global-delta-printed* *global-delta*)))
    (debug:print-info 11 "db:get-var END " var)
    res))

(define (db:set-var db var val)
  (debug:print-info 11 "db:set-var START " var " " val)
  (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)
  (debug:print-info 11 "db:set-var END " var " " val)
)





;; use a global for some primitive caching, it is just silly to re-read the db 
;; over and over again for the keys since they never change

(define (db:get-keys db)
  (if *db-keys* *db-keys* 
      (let ((res '()))

                            t.logdat     
                            t.run_duratio
                            t.comment    
                            t.event_time 
                            t.fail_count 
                            t.pass_count 
                            t.archived   



 FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE "
		       keystr " AND r.runname LIKE '" runname "' AND item_path LIKE '" itempatt "' AND testname LIKE '"
		       testpatt "' AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt 
		       "'ORDER BY t.event_time ASC;")))
    (debug:print 3 "qrystr: " qrystr)
    (sqlite3:for-each-row 
     (lambda (p)
       (set! res (cons p res)))
     db 
     qrystr)
    res))

;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS
;;======================================================================


(define (db:updater)
  (debug:print-info 4 "Starting cache processing")
  (let loop ((start-time (current-time)))
    (thread-sleep! 10) ;; move save time around to minimize regular collisions?
    (db:write-cached-data)
    (loop start-time)))





(define (cdb:test-set-status-state test-id status state msg)
  (debug:print-info 4 "cdb:test-set-status-state test-id=" test-id ", status=" status ", state=" state ", msg=" msg)
  (mutex-lock! *incoming-mutex*)
  (set! *last-db-access* (current-seconds))
  (if msg
      (set! *incoming-data* (cons (vector 'state-status-msg
					  (current-milliseconds)
					  (list state status msg test-id))

				  *incoming-data*))
      (set! *incoming-data* (cons (vector 'state-status
					  (current-milliseconds)
					  (list state status test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) 





				  *incoming-data*)))
  (mutex-unlock! *incoming-mutex*)
  (if *cache-on*
      (debug:print-info 6 "*cache-on* is " *cache-on* ", skipping cache write")



      (db:write-cached-data)))
  
(define (cdb:test-rollup-test_data-pass-fail test-id)
  (debug:print-info 4 "Adding " test-id " for test_data rollup to the queue")

  (mutex-lock! *incoming-mutex*)
  (set! *last-db-access* (current-seconds))
  (set! *incoming-data* (cons (vector 'test_data-pf-rollup

				      (current-milliseconds)
				      (list test-id test-id test-id test-id))

			      *incoming-data*))
  (mutex-unlock! *incoming-mutex*)



  (if *cache-on*

      (debug:print-info 6 "*cache-on* is " *cache-on* ", skipping cache write")


      (db:write-cached-data)))




(define (cdb:pass-fail-counts test-id fail-count pass-count)

  (debug:print-info 4 "Adding " test-id " for setting pass/fail counts to the queue")


  (mutex-lock! *incoming-mutex*)
  (set! *last-db-access* (current-seconds))
  (set! *incoming-data* (cons (vector 'pass-fail-counts
				      (current-milliseconds)
				      (list fail-count pass-count test-id))

			      *incoming-data*))
  (mutex-unlock! *incoming-mutex*)

  (if *cache-on*


      (debug:print-info 6 "*cache-on* is " *cache-on* ", skipping cache write")


      (db:write-cached-data)))



(define (cdb:tests-register-test db run-id test-name item-path #!key (force-write #f))
  (let ((item-paths (if (equal? item-path "")
			(list item-path)
			(list item-path ""))))
    (debug:print-info 4 "Adding " run-id ", " test-name "/" item-path " for setting pass/fail counts to the queue")
    (mutex-lock! *incoming-mutex*)
    (set! *last-db-access* (current-seconds))
    (set! *incoming-data* (cons (vector 'register-test
					(current-milliseconds)
					(list run-id test-name item-path)) ;; fail-count pass-count test-id))
				*incoming-data*))
    (mutex-unlock! *incoming-mutex*)
    (if (and (not force-write) *cache-on*)
	(debug:print-info 6 "*cache-on* is " *cache-on* ", skipping cache write")
	(db:write-cached-data))))

;; The queue is a list of vectors where the zeroth slot indicates the type of query to
;; apply and the second slot is the time of the query and the third entry is a list of 
;; values to be applied
;;
(define (db:write-cached-data)
  (open-run-close
   (lambda (db . params)
     (let ((register-test-stmt    (sqlite3:prepare db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');"))
	   (state-status-stmt     (sqlite3:prepare db "UPDATE tests SET state=?,status=? WHERE id=?;"))
	   (state-status-msg-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;"))
	   (pass-fail-counts-stmt (sqlite3:prepare db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;"))
	   (test_data-rollup-stmt  (sqlite3:prepare db "UPDATE tests
                                             SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
                                                THEN 'FAIL'
                                             WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
                                                  (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
                                             THEN 'PASS'
                                             ELSE status
                                         END WHERE id=?;"))


















	   (data                  #f)
	   (rollups               (make-hash-table)))
       (mutex-lock! *incoming-mutex*)
       (set! data (sort *incoming-data* (lambda (a b)(< (vector-ref a 1)(vector-ref b 1)))))
       (set! *incoming-data* '())
       (mutex-unlock! *incoming-mutex*)
       (if (> (length data) 0)
	   (debug:print-info 4 "Writing cached data " data))
       (sqlite3:with-transaction 
	db
	(lambda ()
	  (debug:print-info 4 "flushing " data " to db")
	  (for-each (lambda (entry)
		      (let ((params (vector-ref entry 2)))




			(debug:print-info 4 "Applying " entry " to params " params)
			(case (vector-ref entry 0)
			  ((state-status)
			   (apply sqlite3:execute state-status-stmt     params))
			  ((state-status-msg)
			   (apply sqlite3:execute state-status-msg-stmt params))
			  ((test_data-pf-rollup)

			   ;; (hash-table-set! rollups (car params) params))

			   (apply sqlite3:execute test_data-rollup-stmt  params))
			  ((pass-fail-counts)
			   (apply sqlite3:execute pass-fail-counts-stmt params))
			  ((register-test)
			   (apply sqlite3:execute register-test-stmt    params))

			  (else
			   (debug:print 0 "ERROR: Queued entry not recognised " entry)))))


		    data)))
       ;; now do any rollups

       ;; (for-each







       ;;  (lambda (test-id)
       ;;    (apply sqlite3:execute test_data-rollup-stmt (hash-table-ref rollups test-id)))
       ;;  (hash-table-keys rollups))
       (sqlite3:finalize! state-status-stmt)
       (sqlite3:finalize! state-status-msg-stmt)
       (sqlite3:finalize! test_data-rollup-stmt)
       (sqlite3:finalize! pass-fail-counts-stmt)
       (sqlite3:finalize! register-test-stmt)
       (let ((cache-size (length data)))
	 (if (> cache-size *max-cache-size*)
	     (set! *max-cache-size* cache-size)))
       ))
   #f))

(define cdb:flush-queue db:write-cached-data)

(define (db:roll-up-pass-fail-counts db run-id test-name item-path status)
  (rdb:flush-queue)
  (if (and (not (equal? item-path ""))
	   (or (equal? status "PASS")
	       (equal? status "WARN")
	       (equal? status "FAIL")
	       (equal? status "WAIVED")
	       (equal? status "RUNNING")))
      (begin

                       SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN 
                          'RUNNING'
                       ELSE 'COMPLETED' END,
                          status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END
                       WHERE run_id=? AND testname=? AND item_path='';"
	     run-id test-name run-id test-name))
	#f)

      #f))

;;======================================================================
;; Tests meta data
;;======================================================================

;; read the record given a testname

	   tdb 
	   "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
                   (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
	   test-id test-id)
	  (sqlite3:finalize! tdb)

	  ;; Now rollup the counts to the central megatest.db
	  (rdb:pass-fail-counts test-id fail-count pass-count)
	  ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;" 
	  ;;                     fail-count pass-count test-id)

	  (thread-sleep! 1) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set
	  
	  ;; if the test is not FAIL then set status based on the fail and pass counts.
	  (rdb:test-rollup-test_data-pass-fail test-id)
	  ;; (sqlite3:execute
	  ;;  db   ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME
	  ;;  "UPDATE tests
          ;;             SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 
          ;;                THEN 'FAIL'
          ;;             WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND 
          ;;                  (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')

;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")


;;======================================================================
;; REMOTE DB ACCESS VIA RPC
;;======================================================================

(define (rdb:open-run-close procname . remargs)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	(apply (rpc:procedure 'rdb:open-run-close host port) procname remargs))
      (apply open-run-close (eval procname) remargs)))

(define (rdb:test-set-status-state test-id status state msg)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	(handle-exceptions
	 exn
	 (begin
	   (debug:print 0 "EXCEPTION: rpc call failed?")
	   (debug:print 0 "  " ((condition-property-accessor 'exn 'message) exn))
	   (print-call-chain)
	   (cdb:test-set-status-state test-id status state msg))
	 ((rpc:procedure 'cdb:test-set-status-state host port) test-id status state msg)))
      (cdb:test-set-status-state test-id status state msg)))

(define (rdb:test-rollup-test_data-pass-fail test-id)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'cdb:test-rollup-test_data-pass-fail host port) test-id))
      (cdb:test-rollup-test_data-pass-fail test-id)))

(define (rdb:pass-fail-counts test-id fail-count pass-count)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'cdb:pass-fail-counts host port) test-id fail-count pass-count))
      (cdb:pass-fail-counts test-id fail-count pass-count)))

;; currently forces a flush of the queue
(define (rdb:tests-register-test db run-id test-name item-path)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'cdb:tests-register-test host port) db run-id test-name item-path force-write: #t))
      (cdb:tests-register-test db run-id test-name item-path force-write: #t)))

(define (rdb:flush-queue)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'cdb:flush-queue host port)))
      (cdb:flush-queue)))

									     (string->number (car parts))
									     #f)))
							    (if p-id
								(begin
								  (debug:print 0 "Killing " (cadr parts) "; kill -9  " p-id)
								  (system (conc "kill -9 " p-id))))))
							(car processes))
						       (system (conc "kill -9 " pid))))
						   (begin
						     (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
						     (tests:test-set-status! test-id "KILLED"  "FAIL"
								     (args:get-arg "-m") #f)
						     (sqlite3:finalize! tdb)
						     (exit 1))))
					     (set! kill-tries (+ 1 kill-tries))
					     (mutex-unlock! m)))
				       ;; (sqlite3:finalize! db)
				       (thread-sleep! (+ 10 (random 10))) ;; 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)
	    (let* ((item-path (item-list->path itemdat))
		   (testinfo  (open-run-close db:get-test-info-by-id #f test-id))) ;; )) ;; run-id test-name item-path)))

	      (if (not (equal? (db:test-get-state testinfo) "COMPLETED"))
		  (begin
		    (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
		    (tests:test-set-status! test-id 
				    (if kill-job? "KILLED" "COMPLETED")
				    (cond
				     ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run

;; Copyright 2006-2012, 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")
;; (include "megatest-version.scm")

(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos) ;; (srfi 18) extras)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))

;; Misc general calls
;;======================================================================

(if (args:get-arg "-env2file")
    (begin
      (save-environment-as-files (args:get-arg "-env2file"))
      (set! *didsomething* #t)))









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

;; since several actions can be specified on the command line the removal
;; is done first

				       (db:step-get-event_time step)))
			     steps)))))
		  tests))))
	   runs)
	  (set! *didsomething* #t)
	  )))

;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;======================================================================
(if (args:get-arg "-server")
    (let* ((toppath (setup-for-run))
	   (db      (if toppath (open-db) #f)))
      (debug:print-info 0 "Starting the standalone server")
      (if db 
	  (let* ((host:port (db:get-var db "SERVER")) ;; this doen't support multiple servers BUG!!!!
		 (th2 (server:start db (args:get-arg "-server")))
		 (th3 (make-thread (lambda ()
				     (server:keep-running db host:port)))))
	    (thread-start! th3)
	    (thread-join! th3)
	    (set! *didsomething* #t))
	  (debug:print 0 "ERROR: Failed to setup for megatest"))))

;;======================================================================
;; 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
;;   add head tasks to task queue
;;   add dependant tasks to task queue 
;;   add remaining tasks to task queue
;; for each task in task queue
;;   if have adequate resources
;;     launch task
;;   else
;;     put task in deferred queue
;; 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")











    (general-run-call 
     "-runall"
     "run all tests"
     (lambda (target runname keys keynames keyvallst)
	 (runs:run-tests target
			 runname
			 (if (args:get-arg "-testpatt")
			     (args:get-arg "-testpatt")
			     "%/%")
			 user
			 args:arg-hash)))) ;; )



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

;; 1. find the config file
;; 2. change to the test directory

	    (current-input-port (make-gnu-readline-port "megatest> "))
	    (repl)))
      (set! *didsomething* #t)))

;;======================================================================
;; Exit and clean up
;;======================================================================





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

;; (if *runremote* (rpc:close-all-connections!))
    
(if (not (eq? *globalexitstatus* 0))

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

(require-extension (srfi 18) extras tcp rpc)
(import (prefix rpc rpc:))

(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo)
(import (prefix sqlite3 sqlite3:))

(declare (unit server))

(declare (uses common))
(declare (uses db))
(declare (uses tests))

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

;; procstr is the name of the procedure to be called as a string
(define (server:autoremote procstr params)

  (handle-exceptions

   exn


   (begin
     (debug:print 1 "Remote failed for " proc " " params)
     (apply (eval (string->symbol procstr)) params))
   ;; (if *runremote*
   ;;    (apply (eval (string->symbol (conc "remote:" procstr))) params)
   (apply (eval (string->symbol procstr)) params)))

(define (server:start db hostn)
  (debug:print 0 "Attempting to start the server ...")
  (let ((host:port      (db:get-var db "SERVER"))) ;; do whe already have a server running?
    (if host:port 
	(set! *runremote* (let* ((lst  (string-split host:port ":"))
				 (port (if (> (length lst) 1)
					   (string->number (cadr lst))
					   #f)))
			    (if port (vector (car lst) port) #f)))
	(let* ((rpc:listener   (server:find-free-port-and-open (rpc:default-server-port)))
	       (th1            (make-thread
				(cute (rpc:make-server rpc:listener) "rpc:server")
				'rpc:server))
	       ;; (th2            (make-thread (lambda ()(db:updater))))
	       (hostname       (if (string=? "-" hostn)
				   (get-host-name) 
				   hostn))
	       (ipaddrstr      (if (string=? "-" hostn)
				   (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
				   #f))
	       (host:port      (conc (if ipaddrstr ipaddrstr hostname) ":" (rpc:default-server-port))))
	  (debug:print 0 "Server started on " host:port)
	  (db:set-var db "SERVER" host:port)

	  (set! *cache-on* #t)
	  
	  ;; can use this to run most anything at the remote
	  (rpc:publish-procedure! 
	   'remote:run 
	   (lambda (procstr . params)
	     (server:autoremote procstr params)))
	  
	  (rpc:publish-procedure!
	   'server:login
	   (lambda (toppath)
	     (set! *last-db-access* (current-seconds))
	     (if (equal? *toppath* toppath)
		 (begin
		   (debug:print-info 2 "login successful")
		   #t)
		 #f)))

	  ;;======================================================================
	  ;; db specials here
	  ;;======================================================================
	  ;; remote call to open-run-close
	  (rpc:publish-procedure!
	   'rdb:open-run-close 
	   (lambda (procname . remargs)
	     (debug:print-info 12 "Remote call of rdb:open-run-close " procname " " remargs)
	     (set! *last-db-access* (current-seconds))
	     (apply open-run-close (eval procname) remargs)))
	  
	  (rpc:publish-procedure!
	   'cdb:test-set-status-state
	   (lambda (test-id status state msg)
	     (debug:print-info 12 "Remote call of cdb:test-set-status-state test-id=" test-id ", status=" status ", state=" state ", msg=" msg)
	     (cdb:test-set-status-state test-id status state msg)))

	  (rpc:publish-procedure!
	   'cdb:test-rollup-test_data-pass-fail
	   (lambda (test-id)
	     (debug:print-info 12 "Remote call of cdb:test-rollup-test_data-pass-fail " test-id)
	     (cdb:test-rollup-test_data-pass-fail test-id)))

	  (rpc:publish-procedure!
	   'cdb:pass-fail-counts
	   (lambda (test-id fail-count pass-count)
	     (debug:print-info 12 "Remote call of cdb:pass-fail-counts " test-id " passes: " pass-count " fails: " fail-count)
	     (cdb:pass-fail-counts test-id fail-count pass-count)))

	  (rpc:publish-procedure!
	   'cdb:tests-register-test
	   (lambda (db run-id test-name item-path)
	     (debug:print-info 12 "Remote call of cdb:tests-register-test " run-id " testname: " test-name " item-path: " item-path)
	     (cdb:tests-register-test db run-id test-name item-path)))

	  (rpc:publish-procedure!
	   'cdb:flush-queue
	   (lambda ()
	     (debug:print-info 12 "Remote call of cdb:flush-queue")
	     (cdb:flush-queue)))

	  ;;======================================================================
	  ;; end of publish-procedure section
	  ;;======================================================================

	  (set! *rpc:listener* rpc:listener)
	  (on-exit (lambda ()
		     (open-run-close
		      (lambda (db . params)
			(sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port))
		      #f ;; for db
		      #f) ;; for a param
		     (let loop ((n 0))
		       (let ((queue-len 0))
			 (thread-sleep! (random 5))
			 (mutex-lock! *incoming-mutex*)
			 (set! queue-len (length *incoming-data*))
			 (mutex-unlock! *incoming-mutex*)
			 (if (> queue-len 0)
			     (begin
			       (debug:print-info 0 "Queue not flushed, waiting ...")
			       (loop (+ n 1)))))
		      )))
	  (db:updater)
	  (thread-start! th1)
	  ;; (debug:print 0 "Server started on port " (rpc:default-server-port) "...")
	  ;; (thread-start! th2)
	  ;; (thread-join!  th2)


	  ;; return th2 for the calling process to do a join with 
	  th1



	  )))) ;; rpc:server)))




(define (server:keep-running db host:port)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  (let loop ((count 0))
    (thread-sleep! 20) ;; no need to do this very often



    (let ((numrunning (db:get-count-tests-running db)))
      (if (or (> numrunning 0)
	      (> (+ *last-db-access* 60)(current-seconds)))
	  (begin
	    (debug:print-info 0 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
	    (loop (+ 1 count)))
	  (begin
	    (debug:print-info 0 "Starting to shutdown the server side")
	    ;; need to delete only *my* server entry (future use)
	    (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' AND val like ?;"  host:port)
	    (thread-sleep! 10)
	    (debug:print-info 0 "Max cached queries was " *max-cache-size*)
	    (debug:print-info 0 "Server shutdown complete. Exiting")
	    ;; (exit)))
	    )))))

(define (server:find-free-port-and-open port)


  (handle-exceptions
   exn
   (begin
     (print "Failed to bind to port " (rpc:default-server-port) ", trying next port")

     (server:find-free-port-and-open (+ port 1)))

   (rpc:default-server-port port)
   (tcp-read-timeout 240000)




   (tcp-listen (rpc:default-server-port) 10000)))

(define (server:client-setup)


  (if *runremote*
      (begin




	(debug:print 0 "ERROR: Attempt to connect to server but already connected")




	#f)
      (let* ((hostinfo (open-run-close db:get-var #f "SERVER"))
	     (hostdat  (if hostinfo (string-split hostinfo ":") #f))

	     (host     (if hostinfo (car hostdat) #f))

	     (port     (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f)))

	(if (and port
		 (string->number port))


	    (let ((portn (string->number port)))

	      (debug:print-info 2 "Setting up to connect to host " host ":" port)
	      (handle-exceptions



	       exn

	       (begin
		 (debug:print 0 "ERROR: Failed to open a connection to the server at host: " host " port: " port)

		 (debug:print 0 "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
		 ;; (open-run-close 
		 ;;  (lambda (db . param) 
		 ;;    (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"))
		 ;;  #f)
		 (set! *runremote* #f))
	       (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server

			((rpc:procedure 'server:login host portn) *toppath*))


		   (begin

		     (debug:print-info 2 "Logged in and connected to " host ":" port)
		     (set! *runremote* (vector host portn)))



		   (begin
		     (debug:print-info 2 "Failed to login or connect to " host ":" port)
		     (set! *runremote* #f)))))
	    (debug:print-info 2 "no server available")))))

			     #f))
		       #f)))
    (if waived (set! real-status "WAIVED"))
    (debug:print 4 "real-status " real-status ", waived " waived ", status " status)

    ;; update the primary record IF state AND status are defined
    (if (and state status)
	(rdb:test-set-status-state test-id real-status state #f))
    
    ;; if status is "AUTO" then call rollup (note, this one modifies data in test
    ;; run area, do not rpc it (yet)
    (if (and test-id state status (equal? status "AUTO")) 
	(db:test-data-rollup #f test-id status))

    ;; add metadata (need to do this way to avoid SQL injection issues)

    ;; :first_err
    ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f)))

	# if [ -e fullrun/megatest.db ]; then sqlite3 fullrun/megatest.db "delete from metadat where var='SERVER';";fi
	mkdir -p /tmp/mt_runs /tmp/mt_links
	cd ..;make install
	rm -f fullrun/logging.db
	touch cleanprep

fullprep : cleanprep

	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt % -itempatt %
	cd fullrun;$(BINPATH)/dboard -rows 15 &

dashboard : cleanprep
	cd fullrun && $(BINPATH)/dashboard -rows 25 &

remove :
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN)  -testpatt % -itempatt % :sysname % :fsname % :datapath %

                                      (and (file-exists? "nada.sh")
    			                 (file-exists? "nada.csh"))))

(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?))

(test "register-test, test info" "NOT_STARTED"
      (begin
	(rdb:tests-register-test *db* 1 "nada" "")
	;; (rdb:flush-queue)
	(vector-ref (db:get-test-info *db* 1 "nada" "") 3)))

(test #f "NOT_STARTED"    
      (begin
	(rdb:tests-register-test #f 1 "nada" "")
	;; (rdb:flush-queue)

						    "n/a" 
						    "bob")))
(define keys (db:get-keys *db*))

;;======================================================================
;; D B
;;======================================================================

(test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def"))
(test #f (vector '("SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time") '())
      (runs:get-runs-by-patt db keys "%"))
(test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))))
(test #f #t (runs:operate-on 'print "%" "%" "%"))

;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" 

;;======================================================================
;; R E M O T E   C A L L S 
;;======================================================================

;; start a server process
(set! *verbosity* 10)
(define server-pid (process-run "../../bin/megatest" (list "-server" "-" "-debug" (conc *verbosity*))))
(sleep 2)




(define start-wait (current-seconds))
(server:client-setup)
(print "Starting intensive cache and rpc test")
(for-each (lambda (params)
	    ;;; (rdb:tests-register-test #f 1 (conc "test" (random 20)) "")
	    (apply rdb:test-set-status-state test-id params)
	    (rdb:pass-fail-counts test-id (random 100) (random 100))
	    (rdb:test-rollup-test_data-pass-fail test-id)
	    (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level
	  '(("COMPLETED"    "PASS" #f)
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")
	    ("NOT_STARTED"  "FAIL" "Just testing")

(use zmq posix)

(define s (make-socket 'req))
(connect-socket s "tcp://127.0.0.1:5563")

(define myname (cadr (argv)))

(print "Start client...")

(do ((i 0 (+ i 1)))
    ((>= i 1000))

(use zmq srfi-18 posix)

(define s (make-socket 'rep))
(bind-socket s "tcp://127.0.0.1:5563")

(print "Start server...")
(let loop ()
  (let* ((msg  (receive-message s))
	 (name (caddr (string-split msg " ")))
	 (resp (conc "World " name)))
    (print "Received request: [" msg "]")
    (thread-sleep! 0.01)
    (print "Sending response \"" resp "\"")
    (send-message s resp)
    (loop)))

  --disable-unshare       \
  --disable-rename        \
  --disable-schedutils    \
  --disable-libblkid      \
  --disable-wall
   make install




#   --disable-chsh-only-listed
#   --disable-pg-bell       let pg not ring the bell on invalid keys
#   --disable-require-password
#   --disable-use-tty-group do not install wall and write setgid tty
#   --disable-makeinstall-chown
#   --disable-makeinstall-setuid
    fi