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")
(define megatest-version 1.08)
(define megatest-version 1.09)

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

Usage: megatest [options]

    (for-each (lambda (testpath)
		(if (file-exists? (conc testpath "/testconfig"))
		    (set! res (cons (last (string-split testpath "/")) res))))
	      tests)
    res))

(define (run-tests db test-names)
  (let* ((keys        (db-get-keys db))
	 (keyvallst   (keys->vallist keys #t))
	 (run-id      (register-run db keys))) ;;  test-name)))
  (for-each 
   (lambda (test-name)
     (let ((num-running (db:get-count-tests-running db))
	   (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")))
       (print "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
       (if (or (not max-concurrent-jobs)
	       (and max-concurrent-jobs
		    (string->number max-concurrent-jobs)
		    (not (> num-running (string->number max-concurrent-jobs)))))
	   (run-one-test db test-name)
	   (print "WARNING: Max running jobs exceeded, current number running: " num-running 
		  ", max_concurrent_jobs: " max-concurrent-jobs))))
   test-names))
    (for-each 
     (lambda (test-name)
       (let ((num-running (db:get-count-tests-running db))
	     (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")))
	 (print "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
	 (if (or (not max-concurrent-jobs)
		 (and max-concurrent-jobs
		      (string->number max-concurrent-jobs)
		      (not (> num-running (string->number max-concurrent-jobs)))))
	     (run-one-test db run-id test-name keyvallst)
	     (print "WARNING: Max running jobs exceeded, current number running: " num-running 
		    ", max_concurrent_jobs: " max-concurrent-jobs))))
     test-names)))

;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc
(define (run-one-test db test-name)
(define (run-one-test db run-id test-name keyvallst)
  (print "Launching test " test-name)
  ;; All these vars might be referenced by the testconfig file reader
  (setenv "MT_TEST_NAME" test-name) ;; 
  (setenv "MT_RUNNAME"   (args:get-arg ":runname"))
  (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
  (change-directory *toppath*)
  (let* ((test-path    (conc *toppath* "/tests/" test-name))
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	 (test-conf    (if testexists (read-config test-configf) (make-hash-table)))
	 (waiton       (let ((w (config-lookup test-conf "requirements" "waiton")))
			 (if (string? w)(string-split w)'()))))
    (if (not testexists)
	(begin
	  (print "ERROR: Can't find config file " test-configf)
	  (exit 2))
	;; put top vars into convenient variables and open the db
	(let* (;; db is always at *toppath*/db/megatest.db
	       (keys        (db-get-keys db))
	       (keyvallst   (keys->vallist keys #t))
	       (items       (hash-table-ref/default test-conf "items" #f))
	       (allitems    (item-assoc->item-list items))
	       (run-id      (register-run db keys)) ;;  test-name)))
	       (runconfigf  (conc  *toppath* "/runconfigs.config")))
	  ;; (print "items: ")(pp allitems)
	  (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
	  (if (args:get-arg "-m")
	      (db:set-comment-for-run db run-id (args:get-arg "-m")))
	  (let loop ((itemdat (car allitems))
		     (tal     (cdr allitems)))
	    ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
	    (let* ((item-path     (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
		   (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))

[setup]
runscript runscript.rb

[requirements]
waiton    runfirst

[items]
MANYITEMS [system ls]
MANYITEMS [system (env > envfile.txt;ls)]
# a b c d e f g h i j k l m
# LSJUNK [system ls]