Megatest

;; Copyright 2006-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; (include "common.scm")
;; (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))

;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;======================================================================
(if (and (args:get-arg "-server")
	 (not (or (args:get-arg "-runall")
		  (args:get-arg "-runtests"))))
    (let* ((toppath (setup-for-run))
	   (db      (if toppath (open-db) #f)))
      (debug:print 0 "INFO: Starting the standalone server")
      (if db 
	  (let ((th2 (server:start db (args:get-arg "-server"))))
	    (thread-join! th2))
	  (debug:print 0 "ERROR: Failed to setup for megatest"))))

;;======================================================================
;; full run
;;======================================================================

;; get lock in db for full run for this directory

		(exit 1)))
	  (set! db (open-db))    
	  (if (not (args:get-arg "-server"))
	      (server:client-setup db))
	  (let* ((itempatt (args:get-arg "-itempatt"))
		 (keys     (rdb:get-keys db))
		 (keynames (map key:get-fieldname keys))
		 (paths    (rdb: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    (rdb:test-get-paths-matching db keynames target)))
	     (for-each (lambda (path)
			 (print path))
		       paths))))))

;;======================================================================
;; Archive tests
;;======================================================================

	      (begin
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))
	  (set! db (open-db))
	  (if (not (args:get-arg "-server"))
	      (server:client-setup db))
	  (if (args:get-arg "-load-test-data")
	      ;; has sub commands that are rdb:
	      (db:load-test-data db run-id test-name itemdat))
	  (if (args:get-arg "-setlog")
	      (rdb:test-set-log! db run-id test-name itemdat (args:get-arg "-setlog")))
	  (if (args:get-arg "-set-toplog")
	      (rdb:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
	  (if (args:get-arg "-summarize-items")
	      (rdb:tests:summarize-items db run-id test-name #t)) ;; do force here
	  (if (args:get-arg "-runstep")
	      (if (null? remargs)
		  (begin
		    (debug:print 0 "ERROR: nothing specified to run!")
		    (sqlite3:finalize! db)
		    (exit 6))
		  (let* ((stepname   (args:get-arg "-runstep"))

			       (oldexitstat 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)
			  (rdb: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 (and (args:get-arg "-test-status")
			 (or (not state)
			     (not status)))
		    (begin
		      (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help)
		      (sqlite3:finalize! db)
		      (exit 6)))
		(rtests:test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m") otherdata)))
	  (sqlite3:finalize! db)
	  (set! *didsomething* #t))))

(if (args:get-arg "-showkeys")
    (let ((db #f)
	  (keys #f))
      (if (not (setup-for-run))