Megatest

PREFIX=.
CSCOPTS= 

SRCFILES = common.scm items.scm launch.scm \
           ods.scm runconfig.scm server.scm configf.scm \
           db.scm keys.scm margs.scm megatest-version.scm \
           process.scm runs.scm tasks.scm tests.scm 

GUISRCF  = dashboard.scm dashboard-tests.scm dashboard-guimonitor.scm dashboard-main.scm

OFILES   = $(SRCFILES:%.scm=%.o)
GOFILES  = $(GUISRCF:%.scm=%.o)

HELPERS=$(addprefix $(PREFIX)/bin/,mt_laststep mt_runstep mt_ezstep)

(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 *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port
(define *runremote*    #f) ;; if set up for server communication this will hold <host port>

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

(define (assoc/default key lst . default)
  (let ((res (assoc key lst)))

;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

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

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

(define (open-db) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((dbpath    (conc *toppath* "/megatest.db")) ;; fname)
	 (configdat (car *configinfo*))
	 (dbexists  (file-exists? dbpath))
	 (db        (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
	 (handler   (make-busy-timeout 36000)))

                     final_logf TEXT DEFAULT 'logs/final.log',
                     logdat     BLOB, 
                     run_duration INTEGER DEFAULT 0,
                     comment    TEXT DEFAULT '',
                     event_time TIMESTAMP,
                     fail_count INTEGER DEFAULT 0,
                     pass_count INTEGER DEFAULT 0,
                     archived   INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
                     CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)
          );")
	  (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname);")
	  (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps 
                              (id INTEGER PRIMARY KEY,
                               test_id INTEGER, 

                                comment TEXT DEFAULT '',
                                status TEXT DEFAULT 'n/a',
                                type TEXT DEFAULT '',
                              CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
	  ;; Must do this *after* running patch db !! No more. 
	  (db:set-var db "MEGATEST_VERSION" megatest-version)
	  ))
    (server:client-setup db)
    db))

;;======================================================================
;; TODO:
;;   put deltas into an assoc list with version numbers
;;   apply all from last to current
;;======================================================================

       (patch-db))
      ((< mver 1.29)
       (db:set-var db "MEGATEST_VERSION" 1.29)
       (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';")
       (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';"))
      ((< mver 1.36)
       (db:set-var db "MEGATEST_VERSION" 1.36)
       (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';"))
      ((< mver 1.37)
       (db:set-var db "MEGATEST_VERSION" 1.37)
       (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;")) 
      ((< mver megatest-version)
       (db:set-var db "MEGATEST_VERSION" megatest-version))))))

;;======================================================================
;; meta get and set vars
;;======================================================================

  (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:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
  (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" 
		   state status run-id test-name item-path))

(define (db:get-count-tests-running db)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART';")

       (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)))
     db 
     "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;"
     test-id)
    res))


(define (db:test-set-comment db run-id test-name item-path comment)
  (sqlite3:execute 
   db 
   "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;"
   comment run-id test-name item-path))

;;
(define (db:test-set-rundir! db run-id test-name item-path rundir)
  (sqlite3:execute 
   db 
   "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;"
   rundir run-id test-name item-path))

(define (db:test-set-log! db run-id test-name item-path logf)
  (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" 
		   logf run-id test-name item-path))

;;======================================================================
;; Misc. test related queries
;;======================================================================

(define (db:test-get-paths-matching db keynames target)
  (let* ((res '())
	 (itempatt   (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "%"))
	 (testpatt   (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
	 (statepatt  (if (args:get-arg ":state")   (args:get-arg ":state")    "%"))
	 (statuspatt (if (args:get-arg ":status")  (args:get-arg ":status")   "%"))
	 (runname    (if (args:get-arg ":runname") (args:get-arg ":runname")  "%"))

    (debug:print 3 "qrystr: " qrystr)
    (sqlite3:for-each-row 
     (lambda (p)
       (set! res (cons p res)))
     db 
     qrystr)
    res))

(define (db:test-get-test-records-matching db keynames target)
  (let* ((res '())
	 (itempatt   (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "%"))
	 (testpatt   (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
	 (statepatt  (if (args:get-arg ":state")   (args:get-arg ":state")    "%"))
	 (statuspatt (if (args:get-arg ":status")  (args:get-arg ":status")   "%"))
	 (runname    (if (args:get-arg ":runname") (args:get-arg ":runname")  "%"))
	 (keystr (string-intersperse 
		  (map (lambda (key val)
			 (conc "r." key " like '" val "'"))
		       keynames 
		       (string-split target "/"))
		  " AND "))
	 (qrystr (conc "SELECT 
                            t.id
                            t.run_id     
                            t.testname   
                            t.host       
                            t.cpuload    
                            t.diskfree   
                            t.uname      
                            t.rundir     
                            t.shortdir   
                            t.item_path  
                            t.state      
                            t.status     
                            t.attemptnum 
                            t.final_logf 
                            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))

(define (db:test-update-meta-info db run-id test-name item-path minutes cpuload diskfree tmpfree)
  (if (not item-path)
      (begin (debug:print 0 "WARNING: ITEMPATH not set.")   
	     (set! item-path "")))
  (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
   test-name
   item-path))

(define (db:roll-up-pass-fail-counts db run-id test-name item-path status)
  (if (and (not (equal? item-path ""))
	   (or (equal? status "PASS")
	       (equal? status "WARN")
	       (equal? status "FAIL")
	       (equal? status "WAIVED")
	       (equal? status "RUNNING")))
      (begin
	(sqlite3:execute 
	 db
	 "UPDATE tests 
             SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'),
                 pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED'))
             WHERE run_id=? AND testname=? AND item_path='';"
	 run-id test-name run-id test-name run-id test-name)
	(if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING
	    (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name)
	    (sqlite3:execute
	     db
	     "UPDATE tests
                       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)))))


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

;; read the record given a testname

	     (if (not (or parent-waiton-met item-waiton-met))
		 (set! result (cons waitontest-name result)))
	     ;; if the test is not found then clearly the waiton is not met...
	     (if (not ever-seen)(set! result (cons waitontest-name result)))))
	waitons)
      (delete-duplicates result))))

(define (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile)
  (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))
	 (testdat   (db:get-test-info db run-id test-name item-path)))
    (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)))
	(debug:print 0 "WARNING: Invalid " (if status "status" "state")
	       " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
    (if testdat
	(let ((test-id (test:get-id testdat)))
	  ;; FIXME - this should not update the logfile unless it is specified.
	  (sqlite3:execute db 
			"INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,strftime('%s','now'),?,?);"
			test-id teststep-name state-in status-in (if comment comment "") (if logfile logfile ""))
	  #t) ;; fake out a #t - could be execute is returning something complicated
	(debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db"))))

;;======================================================================
;; Extract ods file from the db
;;======================================================================

;; runspatt is a comma delimited list of run patterns
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
(define (db:extract-ods-file db outputfile keypatt-alist runspatt pathmod)

	   (debug:print 0 "WARNING: path given, " outputfile " is relative, prefixing with current directory")
	   (conc (current-directory) "/" outputfile)))
     results)
    ;; brutal clean up
    (system "rm -rf tempdir")))

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


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

(define (rdb:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:set-tests-state-status host port)
	 run-id testnames currstate currstatus newstate newstatus))
      (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus)))

(define (rdb:teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile)
  (let ((item-path (item-list->path itemdat)))
    (if *runremote*
	(let ((host (vector-ref *runremote* 0))
	      (port (vector-ref *runremote* 1)))
	  ((rpc:procedure 'rdb:teststep-set-status! host port)
	   run-id test-name teststep-name state-in status-in item-path comment logfile))
	(db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile))))

(define (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree)
  (let ((item-path (item-list->path itemdat)))
    (if *runremote*
	(let ((host (vector-ref *runremote* 0))
	      (port (vector-ref *runremote* 1)))
	  ((rpc:procedure 'rdb:test-update-meta-info host port)
	   run-id test-name item-path minutes cpuload diskfree tmpfree))
	(db:test-update-meta-info db run-id test-name item-path minutes cpuload diskfree tmpfree))))

(define (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:test-set-state-status-by-run-id-testname host port)
	  run-id test-name item-path status state))
      (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)))

(define (rdb:csv->test-data db test-id csvdata)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:csv->test-data host port)
	 test-id csvdata))
      (db:csv->test-data db test-id csvdata)))

(define (rdb:roll-up-pass-fail-counts db run-id test-name item-path status)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:roll-up-pass-fail-counts host port)
	 run-id test-name item-path status))
      (db:roll-up-pass-fail-counts db run-id test-name item-path status)))

(define (rdb:test-set-comment db run-id test-name item-path comment)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:test-set-comment host port)
	 run-id test-name item-path comment))
      (db:test-set-comment db run-id test-name item-path comment)))

(define (rdb:test-set-log! db run-id test-name item-path logf)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rpc:test-set-log! host port)
	 run-id test-name item-path logf))
      (db:test-set-log! db run-id test-name item-path logf)))

;; 		     (season      "summer winter fall spring")))

(declare (unit items))
(declare (uses common))

(include "common_records.scm")

;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
  (let ((res '()))
    (if (not hierdepth)
	(set! hierdepth (length itemlist)))
    (let loop ((hed (car itemlist))
	       (tal (cdr itemlist)))
      (if (null? tal)
	  (for-each (lambda (item)
		      (if (> (length curritemkey) (- hierdepth 2))
			  (set! res (append res (list (append curritemkey (list (list (car hed) item))))))))
		    (cadr hed))
	  (begin
	    (for-each (lambda (item)
			(set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal))))
		      (cadr hed))
	    (loop (car tal)(cdr tal)))))
    res))

;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
  (let ((res '()))
    (if (not hierdepth)
	(set! hierdepth (length itemlist)))
    (let loop ((hed (car itemlist))
	       (tal (cdr itemlist)))
      (if (null? tal)

						   ;;       (set! script (conc script "source " prev-env))))
						   
						   ;; call the command using mt_ezstep
						   (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))

						   (debug:print 4 "script: " script)

						   (rdb:teststep-set-status! db run-id test-name stepname "start" "-" itemdat #f #f)
						   ;; now launch
						   (let ((pid (process-run script)))
						     (let processloop ((i 0))
						       (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
								   (mutex-lock! m)
								   (vector-set! exit-info 0 pid)
								   (vector-set! exit-info 1 exit-status)
								   (vector-set! exit-info 2 exit-code)
								   (mutex-unlock! m)
								   (if (eq? pid-val 0)
								       (begin
									 (thread-sleep! 2)
									 (processloop (+ i 1))))
								   ))
						     (rdb:teststep-set-status! db run-id test-name stepname "end" (vector-ref exit-info 2) itemdat #f (if logpro-used (conc stepname ".html") ""))
						     (if logpro-used
							 (test-set-log! db run-id test-name itemdat (conc stepname ".html")))
						     ;; set the test final status
						     (let* ((this-step-status (cond
									       ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
									       ((eq? (vector-ref exit-info 2) 0)                   'pass)
									       (else 'fail)))

				     (let* ((db       (open-db))
					    (cpuload  (get-cpu-load))
					    (diskfree (get-df (current-directory)))
					    (tmpfree  (get-df "/tmp")))
				       (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")))
				       (set! kill-job? (test-get-kill-request db run-id test-name itemdat))
				       (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree)
				       (if kill-job? 
					   (begin
					     (mutex-lock! m)
					     (let* ((pid (vector-ref exit-info 0)))
					       (if (number? pid)
						   (begin
						     (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")")

;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.37)

(import (prefix base64 base64:))

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

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

(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest

  -rebuild-db             : bring the database schema up to date
  -rollup                 : fill run (set by :runname)  with latest test(s) from
                            prior runs with same keys
  -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.
  -archive                : archive tests, use -target, :runname, -itempatt and -testpatt
  -server -|hostname      : start the server (reduces contention on megatest.db), use
                            - to automatically figure out hostname

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
                            to windows style

			":category"
			":variable"
			":value"
			":expected"
			":tol"
			":units"
			;; misc
			"-server"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-setvars"
			"-debug" ;; for *verbosity* > 2
			) 
		 (list  "-h"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-test-status"
			"-set-values"
			"-load-test-data"
			"-summarize-items"
		        "-gui"
			;; misc
			"-archive"
			;; queries
			"-test-paths" ;; get path(s) to a test, ordered by youngest first

			"-runall"    ;; run all tests
			"-remove-runs"
			"-keepgoing"
			"-usequeue"
			"-rebuild-db"
			"-rollup"
			"-update-meta"

			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only
		       )
		 args:arg-hash
		 0))

(if (args:get-arg "-h")

		     runname
		     (args:get-arg "-runtests")
		     (args:get-arg "-itempatt")
		     user
		     (make-hash-table)))))

;;======================================================================
;; Start the server
;;======================================================================
(if (args:get-arg "-server")
    (let* ((toppath (setup-for-run))
	   (db      (if toppath (open-db) #f)))
      (if db 
	  (server:start db (args:get-arg "-server"))
	  (debug:print 0 "ERROR: Failed to setup for megatest"))))

;;;======================================================================
;; Rollup into a run
;;======================================================================
(if (args:get-arg "-rollup")
    (general-run-call 
     "-rollup" 
     "rollup tests" 
     (lambda (db keys keynames keyvallst)
       (runs:rollup-run db
			keys
			(keys->alist keys "na")
			(args:get-arg ":runname") 
			user))))

;;======================================================================
;; Get paths to tests
;;======================================================================
;; Get test paths matching target, runname, testpatt, and itempatt
(if (args:get-arg "-test-paths")
    ;; if we are in a test use the MT_CMDINFO data
    (if (getenv "MT_CMDINFO")
	(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))

	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -test-paths, exiting")
		(exit 1)))
	  (set! db (open-db))    
	  (let* ((itempatt (args:get-arg "-itempatt"))
		 (keys     (db-get-keys db))
		 (keynames (map key:get-fieldname keys))
		 (paths    (db:test-get-paths-matching db keynames target)))
	    (set! *didsomething* #t)
	    (for-each (lambda (path)
			(print path))
		      paths)))
	;; else do a general-run-call
	(general-run-call 
	 "-test-paths"
	 "Get paths to tests"
	 (lambda (db target runname keys keynames keyvallst)
	   (let* ((itempatt (args:get-arg "-itempatt"))
		  (paths    (db:test-get-paths-matching db keynames target)))
	     (for-each (lambda (path)
			 (print path))
		       paths))))))

;;======================================================================
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, testpatt, and itempatt
(if (args:get-arg "-archive")
    ;; if we are in a test use the MT_CMDINFO data
    (if (getenv "MT_CMDINFO")
	(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"))
	       (target    (args:get-arg "-target")))
	  (change-directory testpath)
	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -archive, exiting")
		(exit 1)))
	  (set! db (open-db))    
	  (let* ((itempatt (args:get-arg "-itempatt"))
		 (keys     (db-get-keys db))
		 (keynames (map key:get-fieldname keys))
		 (paths    (db:test-get-paths-matching db keynames target)))
	    (set! *didsomething* #t)
	    (for-each (lambda (path)

	  (change-directory testpath)
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))
	  (set! db (open-db))
	  (if (and state status)
	      (rdb:teststep-set-status! db run-id test-name step state status itemdat (args:get-arg "-m") logfile)
	      (begin
		(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

			 (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
		    (rdb:teststep-set-status! db run-id test-name stepname "start" "n/a" itemdat (args:get-arg "-m") logfile)
		    ;; close the db
		    (sqlite3:finalize! db)
		    ;; run the test step
		    (debug:print 2 "INFO: Running \"" fullcmd "\"")
		    (change-directory startingdir)
		    (set! exitstat (system fullcmd)) ;; cmd params))
		    (set! *globalexitstatus* exitstat)

			       (cmd         (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
			  (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)))
		    (rdb:teststep-set-status! db run-id test-name stepname "end" exitstat itemdat (args:get-arg "-m") logfile)
		    (sqlite3:finalize! db)
		    (if (not (eq? exitstat 0))
			(exit 254)) ;; (exit exitstat) doesn't work?!?
		  ;; open the db
		  ;; mark the end of the test
		  )))
	  (if (or (args:get-arg "-test-status")

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

    (if (eq? *passnum* 0)
	(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")
	  (rdb:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))

    ;; now add non-directly referenced dependencies (i.e. waiton)
    (if (not (null? test-names))
	(let loop ((hed (car test-names))
		   (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	  (let* ((config  (test:get-testconfig hed 'return-procs))
		 (waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))

    
    ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
    (let* ((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       (db:get-test-info db run-id test-name item-path)))
      (if (not testdat)
	  (begin
	    ;; ensure that the path exists before registering the test
	    (system (conc "mkdir -p " new-test-path))
	    (register-test db run-id test-name item-path)
	    (set! testdat (db:get-test-info db run-id test-name item-path))))
      (change-directory test-path)
      (case (if force ;; (args:get-arg "-force")
		'NOT_STARTED
		(if testdat
		    (string->symbol (test:get-state testdat))

;; 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.

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

(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 proc)) params))
   (if *runremote*
       (apply (eval (string->symbol (conc "remote:" procstr))) params)
       (eval (string->symbol procstr) params))))

(define (server:start db hostn)
  (debug:print 0 "Attempting to start the server ...")
  (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))
	 (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))))
    (db:set-var db "SERVER" host:port)
    (rpc:publish-procedure! 
     'remote:run 
     (lambda (procstr . params)
       (server:autoremote procstr params)))

    ;;======================================================================
    ;; db specials here
    ;;======================================================================
    ;; ** set-tests-state-status
    (rpc:publish-procedure!
     'rdb:set-tests-state-status 
     (lambda (run-id testnames currstate currstatus newstate newstatus)
       (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus)))

    (rpc:publish-procedure!
     'rdb:teststep-set-status!
     (lambda (run-id test-name teststep-name state-in status-in item-path comment logfile)
       (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile)))

    (rpc:publish-procedure!
     'rdb:test-update-meta-info
     (lambda (run-id testname item-path minutes cpuload diskfree tmpfree)
       (db:test-update-meta-info db run-id testname item-path minutes cpuload diskfree tmpfree)))
     
    (rpc:publish-procedure!
     'rdb:test-set-state-status-by-run-id-testname
     (lambda (run-id test-name item-path status state)
       (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)))

    (rpc:publish-procedure!
     'rdb:csv->test-data 
     (lambda (test-id csvdata)
       (db:csv->data db test-id csvdata)))

    (rpc:publish-procedure!
     'rdb:roll-up-pass-fail-counts
     (lambda (run-id test-name item-path status)
       (db:roll-up-pass-fail-counts db run-id test-name item-path status)))

    (rpc:publish-procedure!
     'rdb:test-set-comment 
     (lambda (run-id test-name item-path comment)
       (db:test-set-comment db run-id test-name item-path comment)))
    
    (rpc:publish-procedure!
     'rpc:test-set-log!
     (lambda (run-id test-name item-path logf)
       (db:test-set-log! db run-id test-name item-path logf)))

    (set! *rpc:listener* rpc:listener)
    (on-exit (lambda ()
	       (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port)
	       (sqlite3:finalize! db)))
    (thread-start! th1)
    (thread-join! th1))) ;; rpc:server)))

(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-listen (rpc:default-server-port))))

(define (server:client-setup db)
  (let* ((hostinfo (db:get-var db "SERVER"))
	 (hostdat  (if hostinfo (string-split hostinfo ":")))
	 (host     (if hostinfo (car hostdat)))
	 (port     (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f)))
    (if (and port
	     (string->number port))
	(debug:print 2 "INFO: Setting up to connect to host " host ":" port))
    (set! *runremote* (if port (vector host (string->number port)) #f))))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")


(define (register-test db run-id test-name item-path)
  (let ((item-paths (if (equal? item-path "")
			(list item-path)
			(list item-path ""))))
    (for-each 
     (lambda (pth)
       (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" 

			   ;; this test is younger, store it in the hash
			   (hash-table-set! tests-hash full-testname testdat))))
		   results)
		  (if (null? tal)
		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
		      (loop (car tal)(cdr tal))))))))))

;; 
(define (test-set-status! db run-id test-name state status itemdat-or-path comment dat)
  (let* ((real-status status)
	 (item-path   (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path)))
	 (testdat     (db:get-test-info db run-id test-name item-path))
	 (test-id     (if testdat (db:test-get-id testdat) #f))
	 (otherdat    (if dat dat (make-hash-table)))
	 ;; before proceeding we must find out if the previous test (where all keys matched except runname)

			     #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-state-status-by-run-id-testname db run-id test-name item-path real-status state))

    ;; 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 db 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)))

	  (units    (hash-table-ref/default otherdat ":units"    ""))
	  (type     (hash-table-ref/default otherdat ":type"     ""))
	  (dcomment (hash-table-ref/default otherdat ":comment"  "")))
      (debug:print 4 
		   "category: " category ", variable: " variable ", value: " value
		   ", expected: " expected ", tol: " tol ", units: " units)
      (if (and value expected tol) ;; all three required
	  (rdb:csv->test-data db test-id 
			     (conc category ","
				   variable ","
				   value    ","
				   expected ","
				   tol      ","
				   units    ","
				   dcomment ",," ;; extra comma for status
				   type     ))))
				   
    ;; need to update the top test record if PASS or FAIL and this is a subtest













    (rdb:roll-up-pass-fail-counts db run-id test-name item-path status)











    (if (or (and (string? comment)
		 (string-match (regexp "\\S+") comment))
	    waived)

	(rdb:test-set-comment db  run-id test-name item-path (if waived waived comment)))
    ))

(define (test-set-log! db run-id test-name itemdat logf) 
  (let ((item-path (item-list->path itemdat)))

    (rdb:test-set-log! db run-id test-name item-path logf)))

(define (test-set-toplog! db run-id test-name logf) 
  (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" 
		   logf run-id test-name))

(define (tests:summarize-items db run-id test-name force)
  ;; if not force then only update the record if one of these is true:

		     #f))))))))


;;======================================================================
;; test steps
;;======================================================================

;; teststep-set-status! used to be here


















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

		  diskfree
		  uname
		  runpath
		  run-id
		  testname
		  item-path)))


;;======================================================================
;; A R C H I V I N G
;;======================================================================





(define (test:archive db test-id)


  #f)





(define (test:archive-tests db keynames target)
  #f)

[setup]
runscript idontexist