Megatest

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses processmod))
(declare (uses configfmod))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
(declare (uses mtargs))

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

;; (include "debugger.scm")

(import commonmod
	processmod
	configfmod
	debugprint
	rmtmod
	dbfile
	(prefix mtargs args:))

;; use this struct to facilitate refactoring
;;

  ;; Take advantage of a good place to exit if running the one-pass methodology
  (if (and (> (runs:dat-can-run-more-tests-count runsdat) 20)
	   (args:get-arg "-one-pass"))
      (exit 0))

  (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))

  (let* ((num-running             (rmt:get-count-tests-running-for-run-id run-id))
	 (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
	 (job-group-limit         (let ((jobg-count (configf:lookup *configdat* "jobgroups" jobgroup)))
				    (if (string? jobg-count)
					(string->number jobg-count)
					jobg-count))))
    (if (> (+ num-running num-running-in-jobgroup) 0)
	(runs:inc-can-run-more-tests-count runsdat)) ;; (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1)))

    ;; Here is where the test_meta table is best updated
    ;; Yes, another use of a global for caching. Need a better way?
    ;;
    ;; There is now a single call to runs:update-all-test_meta and this 
    ;; per-test call is not needed. Given the delicacy of the move to 
    ;; v1.55 this code is being left in place for the time being.
    ;;
    (if (not (hash-table-exists? *test-meta-updated* test-name))
        (begin
          (hash-table-set! *test-meta-updated* test-name #t)
          (runs:update-test_meta test-name test-conf)))
    
    ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer"))
    (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
	   (test-id       (rmt:get-test-id run-id test-name item-path))

	       (begin
		 (case action
                   ((kill-runs)
                    (tasks:kill-runner target run-name "%")
                    (debug:print 1 *default-log-port* "Killing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
                    )
		   ((remove-runs)
		    ;; use this location to cleanup old DELETED records? No. See below for same call
		    ;; (rmt:delete-old-deleted-test-records run-id)
		    ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
		    ;; seek and kill in flight -runtests with % as testpatt here
		    ;; (if (equal? testpatt "%")
		    (tasks:kill-runner target run-name testpatt)
		    ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt))
		    (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((set-state-status)

                    (debug:print 2 *default-log-port* "run-paths-hash: " (hash-table-keys run-paths-hash))

                    (debug:print 1 *default-log-port* "Removing target " target "run: " run-name)
                    (if (not keep-records)
                      (begin
                        (debug:print 1 *default-log-port* "Removing DB records for the run.")
                        (rmt:delete-run run-id)
                        (rmt:delete-old-deleted-test-records run-id))
                    )
                    (if (not (equal?  linkspath "/does/not/exist/I"))
	               (begin 
                         (debug:print 1 *default-log-port* "Recursively removing links dir " linkspath)
                         (runs:recursive-delete-with-error-msg linkspath)))

                   (for-each (lambda(runpath)