Megatest

(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 in ('RUNNING','LAUNCHED','REMOTEHOSTSTART','NOT_STARTED');")
     "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART');") ;; remove NOT_STARTED
    res))

(define (db:get-count-tests-running-in-jobgroup db jobgroup)
  (if (not jobgroup)
      0 ;; 
      (let ((res 0))
	(sqlite3:for-each-row

;; 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)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format 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))
(declare (uses launch))
(declare (uses server))
(declare (uses tests))
(declare (uses genexample))

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")

(define (toplevel-command . param) #f)

(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2012

Usage: megatest [options]

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

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

(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

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

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

      (debug:print 0 "INFO: 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))
	    (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

    (let* ((toppath (setup-for-run))
	   (db      (if toppath (open-db) #f)))
      (if db
	  (begin
	    (set! *db* db)
	    (if (not (args:get-arg "-server"))
		(server:client-setup))
	    (import readline)
	    (import apropos)
	    (gnu-history-install-file-manager
	     (string-append
	      (or (get-environment-variable "HOME") ".") "/.megatest_history"))
	    (current-input-port (make-gnu-readline-port "megatest> "))
	    ;; (import readline)
	    ;; (import apropos)
	    ;; (gnu-history-install-file-manager
	    ;;  (string-append
	    ;;   (or (get-environment-variable "HOME") ".") "/.megatest_history"))
	    ;; (current-input-port (make-gnu-readline-port "megatest> "))
	    (repl)))
      (set! *didsomething* #t)))

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