Megatest

	    (remparam (list-tail params 2))) 
	(debug:print-info 12 "cdb:cached-access qry-name=" qry-name " params=" params)
	(if (not cached?)(db:write-cached-data))
	;; Any special calls are dispatched here. 
	;; Remainder are put in the db queue
	(case qry-name
	  ((login) ;; login checks that the megatest path matches
	   (if (eq? (length remparam) 2) ;; should get toppath and signature
	       #f ;; no path - fail!
	       (let ((calling-path (car remparam)))
		 (if (equal? calling-path *toppath*)
		     (begin
		       (hash-table-set! *logged-in-clients* (cadr remparam) (current-seconds))
		       #t)      ;; path matches - pass! Should vet the caller at this time ...
		     #f))))  ;; else fail to login
	  ((logout)
	   (if (and (> (length remparam) 1)
		    (eq? *toppath* (car remparam))
		    (hash-table-ref/default *logged-in-clients* (cadr remparam) #f))
	       #t
	       #f))
	  ((flush)
	   (db:write-cached-data)
	   #t)
	  ((immediate)
	   (db:write-cached-data)
	   (if (not (null? remparam))
	       (apply (car remparam) (cdr remparam))

  (let ((zdat (db:obj->string params)) ;; (with-output-to-string (lambda ()(serialize params))))
	(res  #f))
    (send-message zmq-socket zdat)
    (set! res (db:string->obj (receive-message zmq-socket zdat)))
    (debug:print-info 11 "zmq-socket " (car params) " res=" res)
    res))
  
(define (cdb:set-verbosity zmq-socket val)
  (cdb:client-call zmq-socket 'set-verbosity #f val))

(define (cdb:login zmq-socket keyval signature)
  (cdb:client-call zmq-socket 'login #t keyval signature))

(define (cdb:logout zmq-socket keyval signature)
  (cdb:client-call zmq-socket 'logout #t keyval signature))

(define (cdb:test-set-status-state zmqsocket test-id status state msg)
  (if msg
      (cdb:client-call zmqsocket 'state-status-msg #t state status msg test-id)
      (cdb:client-call zmqsocket 'state-status #t state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) 

(define (cdb:test-rollup-test_data-pass-fail zmqsocket test-id)

  -rebuild-db             : bring the database schema up to date
  -update-meta            : update the tests metadata for all tests
  -env2file fname         : write the environment to fname.csh and fname.sh
  -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
                                 overwritten by values set in config files.
  -server -|hostname      : start the server (reduces contention on megatest.db), use
                            - to automatically figure out hostname
  -listservers            : list the servers 
  -killserver host:port|pid : kill server specified by host:port or pid, use % to kill all
  -repl                   : start a repl (useful for extending megatest)

Spreadsheet generation
  -extract-ods fname.ods  : extract an open document spreadsheet from the database
  -pathmod path           : insert path, i.e. path/runame/itempath/logfile.html
                            will clear the field if no rundir/testname/itempath/logfile
                            if it contains forward slashes the path will be converted

			":variable"
			":value"
			":expected"
			":tol"
			":units"
			;; misc
			"-server"
			"-killserver"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-setvars"
			"-set-state-status"
			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-test"

			"-summarize-items"
		        "-gui"
			;; misc
			"-archive"
			"-repl"
			"-lock"
			"-unlock"
			"-listservers"
			;; queries
			"-test-paths" ;; get path(s) to a test, ordered by youngest first

			"-runall"    ;; run all tests
			"-remove-runs"
			"-usequeue"
			"-rebuild-db"

;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;   we start the server if not running else start the client thread
;;======================================================================

(if (args:get-arg "-server")
    (server:launch))

(define *logged-in-clients* (make-hash-table))

(if (or (args:get-arg "-listservers")
	(args:get-arg "-killserver"))
    (let ((tl (setup-for-run)))
      (if tl 
	  (let ((servers (open-run-close tasks:get-all-servers tasks:open-db))
		(fmtstr  "~5a~8a~20a~5a~20a~8a~10a\n"))
	    (format #t fmtstr "Id" "Pid" "Host" "Port" "Time" "Priority" "State")
	    (format #t fmtstr "==" "===" "====" "====" "====" "========" "=====")
	    (for-each 
	     (lambda (server)
	       (let* ((id         (vector-ref server 0))
		      (pid        (vector-ref server 1))
		      (hostname   (vector-ref server 2))
		      (port       (vector-ref server 3))
		      (start-time (vector-ref server 4))
		      (priority   (vector-ref server 5))
		      (state      (vector-ref server 6))
		      (accessible (handle-exceptions
				   exn
				   #f
				   (let ((zmq-socket (server:client-login hostname port)))
				     (if zmq-socket
					 (server:client-logout zmq-socket)
					 #f)))))
		 (format #t fmtstr id pid hostname port start-time priority 
			 (cond
			  (accessible "ACCESSIBLE")
			  (else       "DEAD")))))
		 servers)))))

(if (or (let ((res #f))
	  (for-each
	   (lambda (key)
	     (if (args:get-arg key)(set! res #t)))
	   (list "-h" "-version" "-gen-megatest-area" "-gen-megatest-test"))
	  res)

;; 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 s11n)
(import (prefix rpc rpc:))

(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo zmq md5 message-digest)
(import (prefix sqlite3 sqlite3:))

(declare (unit server))

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

       (print "Trying to start server on " zmq-url)
       (bind-socket s zmq-url)
       (set! *runremote* #f)
       (debug:print 0 "Server started on " zmq-url)
       (open-run-close tasks:server-register tasks:open-db (current-process-id) host p 0 'live)
       s))))

(define (server:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
					  (argv)))))))

;; MOVE ME TO COMMON
(define *my-client-signature* #f)

(define (server:client-login host port)
  (let ((connect-ok #f)
	(zmq-socket (make-socket 'req))
	(mysig      (if *my-client-signature* *my-client-signature* (server:mk-signature)))
	(conurl     (server:make-server-url (list host port))))
    (set! *my-client-signature* mysig)
    (connect-socket zmq-socket conurl)
    (if (cdb:login zmq-socket *toppath* mysig)
	zmq-socket
	(if (socket? *runremote*)
	    (begin
	      (close-socket *runremote*)
	      #f)
	    zmq-socket))))

(define (server:client-logout zmq-socket)
  (and (socket? zmq-socket)
       (cdb:logout zmq-socket *toppath* *my-client-signature*)
       (close-socket zmq-socket)))

(define (server:client-setup)
  (if (not *toppath*)(setup-for-run))
  (let* ((hostinfo   (open-run-close tasks:get-best-server tasks:open-db))
	 (zmq-socket (make-socket 'req)))
    (if hostinfo
	(begin
	  (debug:print-info 2 "Setting up to connect to " hostinfo)
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 0 "ERROR: Failed to open a connection to the server at: " hostinfo)
	     (debug:print 0 "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 0 "   perhaps jobs killed with -9? Removing server records")
	     (open-run-close tasks:server-deregister tasks:open-db (car hostinfo) port: (cadr hostinfo))
	     ;; (exit) ;; why forced exit?
	     #f)
	   ;; REPLACE WITH server:client-login
	   ;;
	   (let ((connect-ok #f)
		 (conurl     (server:make-server-url hostinfo)))
	     (connect-socket zmq-socket conurl)
	     (set! connect-ok (cdb:login zmq-socket))
	     (if connect-ok
		 (begin
		   (debug:print-info 2 "Logged in and connected to " conurl)
		   (set! *runremote* zmq-socket)
		   #t)
		 (begin
		   (debug:print-info 2 "Failed to login or connect to " conurl)

    (sqlite3:for-each-row
     (lambda (id hostname port)
       (set! res (list hostname port)))
     mdb
     "SELECT id,hostname,port FROM servers WHERE state='live' ORDER BY start_time DESC LIMIT 1;")
    res))

(define (tasks:get-all-servers mdb)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (id pid hostname port start-time priority state)
       (set! res (cons (vector id pid hostname port start-time priority state) res)))
     mdb
     "SELECT id,pid,hostname,port,start_time,priority,state FROM servers ORDER BY start_time ASC;")
    res))
       

;;======================================================================
;; Tasks and Task monitors
;;======================================================================


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

							 (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live)
							 (set! res (open-run-close tasks:get-best-server tasks:open-db))
							 res))
(test "de-register server" #f (let ((res #f))
				(open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
				(open-run-close tasks:get-best-server tasks:open-db)))


;; (exit)

(set! *verbosity* 3) ;; enough to trigger turning off exception handling in db accesses
(define server-pid (process-run "../../bin/megatest" (list "-server" "-" "-debug" (conc *verbosity*))))
(sleep 3)
(set! *verbosity* 1)

(define hostinfo #f)
(test #f #t (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
				   (set! hostinfo dat)
				   (and (string? (car dat))
					(number? (cadr dat)))))

(test #f #t (socket? (let ((s (server:client-login (car hostinfo)(cadr hostinfo))))
		       (set! *runremote* s)
		       s)))

(define th1 (make-thread (lambda ()(server:client-setup))))
(thread-start! th1)

(test #f #t (cdb:login *runremote* *toppath* *my-client-signature*))
(test #f #t (socket? *runremote*))

(exit)

;;======================================================================
;; C O N F I G   F I L E S 
;;======================================================================

(define conffile #f)
(test "Read a config" #t (hash-table? (read-config "test.config" #f #f)))