Megatest

  license GPL, Copyright Matt Welland 2006-2012

Usage: megatest [options]
  -h                      : this help
  -version                : print megatest version (currently " megatest-version ")

Launching and managing runs
  -run testpatt[/itempatt] : run all tests that are not state COMPLETED and status PASS, 
                            CHECK or KILLED, matching pattern testpatt...

  -remove-runs            : remove the data for a run, requires :runname and -testpatt
                            Optionally use :state and :status
  -set-state-status X,Y   : set state to X and status to Y, requires controls per -remove-runs
  -rerun FAIL,WARN...     : force re-run for tests with specificed status(s)
  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
                            from prior runs with same keys
  -lock                   : lock run specified by target and runname

			"-env2file"
			"-setvars"
			"-set-state-status"
			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all
			"-run"
			) 
		 (list  "-h"
			"-version"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-test-status"

;;     launch task
;;   else
;;     put task in deferred queue
;; if still ok to run tasks
;;   process deferred tasks per above steps

;; run all tests are are Not COMPLETED and PASS or CHECK
(if (or (args:get-arg "-runall") ;; deprecated
	(args:get-arg "-run")
	(args:get-arg "-runtests"))
    (begin
      (if (args:get-arg "-testpatt")
	  (begin
	    (debug:print 0 "ERROR:-testpatt is deprecated, use -run patt1,patt2... instead, your pattern " (args:get-arg "-testpatt") " will be ignored")
	    (sleep 3)))
      (if (args:get-arg "-itempatt")
	  (begin
	    (debug:print 0 "ERROR: -itempatt is not used with -run, your pattern " (args:get-arg "-itempatt") " will be ignored")
	    (sleep 3)))
      (if (args:get-arg "-runall")
	  (begin
	    (debug:print 0 "ERROR: -runall is deprecated, use -run patt1,patt2 ... instead")
	    (sleep 3)))
      (if (args:get-arg "-runtests")
	  (debug:print 0 "WARNING: -runtests is deprecated, use -run patt1,patt2 ... instead"))
      (general-run-call 
       "-run"
       "run tests"
       (lambda (target runname keys keynames keyvallst)
	 (runs:run-tests target
			 runname

			 '()
			 (or (args:get-arg "-run")
			     (args:get-arg "-runtests")
			     (args:get-arg "-testpatt"))
			 user
			 args:arg-hash)))))

;;======================================================================
;; run one test
;;======================================================================

;; 1. find the config file
;; 2. change to the test directory
;; 3. update the db with "test started" status, set running host
;; 4. process launch the test
;;    - monitor the process, update stats in the db every 2^n minutes
;; 5. as the test proceeds internally it calls megatest as each step is
;;    started and completed
;;    - step started, timestamp
;;    - step completed, exit status, timestamp
;; 6. test phone home
;;    - if test run time > allowed run time then kill job
;;    - if cannot access db > allowed disconnect time then kill job

;; (if (args:get-arg "-runtests")
;;   (general-run-call 
;;    "-runtests" 
;;    "run a test" 
;;    (lambda (target runname keys keynames keyvallst)
;;      (runs:run-tests target
;; 		     runname
;; 		     (args:get-arg "-runtests")
;; 		     (args:get-arg "-testpatt")
;; 		     user
;; 		     args:arg-hash))))

;;======================================================================
;; Rollup into a run
;;======================================================================

(if (args:get-arg "-rollup")
    (begin

    (if (file-exists? runconfigf)
	(open-run-close setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars")
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
    
    ;; look up all tests matching the comma separated list of globs in
    ;; test-patts (using % as wildcard)

    (set! test-names (append (tests:get-valid-tests *toppath* test-patts) test-names))
    (set! test-names (delete-duplicates test-names))

    (debug:print-info 0 "test names " test-names)

    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified
    (if (eq? *passnum* 0)

(define (runs:run-tests-queue run-id runname test-records keyvallst flags test-patts)
    ;; At this point the list of parent tests is expanded 
    ;; NB// Should expand items here and then insert into the run queue.
  (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags))
  (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records))
	(test-registery    (make-hash-table))
	(num-retries        0)
	(max-retries       (config-lookup *configdat* "setup" "maxretries"))
	(dotfilep          (if (args:get-arg "-dotfile")(open-output-file (args:get-arg "-dotfile")) #f)))
    (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100))
    (if (not (null? sorted-test-names))
	(let loop ((hed         (car sorted-test-names))
		   (tal         (cdr sorted-test-names))
		   (reruns      '()))
	  (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns))
	  ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns)

		  (thread-sleep! (+ 2 *global-delta*))
		  ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
		  (loop (car newtal)(cdr newtal) reruns))
		 ((and have-resources
		       (or (null? prereqs-not-met)
			   (and (eq? testmode 'toplevel)
				(null? non-completed))))
		  (if dotfilep
		      (with-output-to-port (lambda ()
					     (for-each (lambda (w)
							 (print " " w " -> " test-name ";"))
						       waitons)
					     (print " " test-name ";")))
		      (run:test run-id runname keyvallst test-record flags #f))
		  (thread-sleep! *global-delta*)
		  (if (not (null? tal))
		      (loop (car tal)(cdr tal) reruns)))
		 (else ;; must be we have unmet prerequisites
		    (debug:print 4 "FAILS: " fails)
		    ;; If one or more of the prereqs-not-met are FAIL then we can issue
		    ;; a message and drop hed from the items to be processed.

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

(define (tests:get-valid-tests testsdir test-patts) ;;  #!key (test-names '()))
  (let ((tests  (glob (conc testsdir "/tests/*"))) ;; " (string-translate patt "%" "*")))))
	;; strip off all itempatt portions
	(modpat (string-intersperse
		 (map
		  (lambda (x)(first (string-split x "/")))
		  (string-split test-patts ",")) ",")))
    (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
    (delete-duplicates
     (filter (lambda (testname)
	       (tests:match modpat testname #f))
	     (map (lambda (testp) ;; extract the testname from <test>/testconfig
		    (last (string-split testp "/")))
		  tests)))))

;; tests:glob-like-match
(define (tests:glob-like-match patt str) 
  (let ((like (substring-index "%" patt)))
    (let* ((notpatt  (equal? (substring-index "~" patt) 0))

;; tests:glob-like-match
(test #f '("abc") (tests:glob-like-match "abc" "abc"))
(for-each 
 (lambda (patt str expected)
   (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str)))
 (list "abc"    "~abc" "~abc" "a*c"  "a%c")
 (list "abc"    "abcd" "abc"  "ABC"  "ABC")
 (list '("abc")  #t      #f     #f '("ABC")))

(test #f '("sqlite3speed") (tests:get-valid-tests *toppath* "%sqlite%") )

;; tests:match
(test #f #t (tests:match "abc/def" "abc" "def"))
(for-each 
 (lambda (row) ;; erns testname itempath expected)
   (let ((patterns (list-ref row 0))
	 (testname (list-ref row 1))
	 (itempath (list-ref row 2))
	 (expected (list-ref row 3)))
     (test (conc patterns " " testname "/" itempath "=>" expected)
	   expected 
	   (tests:match patterns testname itempath))))
 '(("abc"        "abc"   ""      #t)
   ("abc/%"      "abc"   ""      #t)
   ("ab%/c%"     "abcd"  "cde"   #t)
   ("ab%/c%"     "def"   ""      #t)
   ("~abc/c%"    "abc"   "cde"   #f)
   ("abc/~c%"    "abc"   "cde"   #f)
   ("a,b/c,%/d"  "a"     ""      #t)
   ("%/,%/a"     "abc"   ""      #t)
   ("%/,%/a"     "def"   "a"     #t)
   ("%/,%/a"     "ghi"   "b"     #f)
   ("%"          "a"     ""      #t)
   ("%"          "a"     "b"     #t)
   ("%/"         "a"     ""      #t)
   ("%/"         "a"     "b"     #f)))

;; db:patt->like
(test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND "))
(test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND "))
(test #f "item_path GLOB ''" (db:patt->like "item_path" ""))

;; test:match->sqlqry
(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')"
      (tests:match->sqlqry "a/b,a%,/b%"))
(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')"
      (tests:match->sqlqry "a/b,a%,%/b%"))

(exit)

;;======================================================================
;; S E R V E R
;;======================================================================

(test "setup for run" #t (begin (setup-for-run)
				(string? (getenv "MT_RUN_AREA_HOME"))))