Megatest

(declare (uses tests))
;; (declare (uses server))
;; (declare (uses runs))
(declare (uses rmt))
;; (declare (uses filedb))

(declare (uses commonmod))

(import commonmod)


(declare (uses configfmod))
(import configfmod)

(declare (uses dbmod))
(import dbmod)

  #t);)
	;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment)))

(define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment)
  (let ((test-id (rmt:get-test-id run-id test-name item-path)))
    (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment)))
    
(define (mt:lazy-read-test-config test-name)
  (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
    (if tconf
	tconf
	(let ((test-dirs (tests:get-tests-search-path *configdat*)))
	  (let loop ((hed (car test-dirs))
		     (tal (cdr test-dirs)))
	    ;; Setting MT_LINKTREE here is almost certainly unnecessary. 
	    (let ((tconfig-file (conc hed "/" test-name "/testconfig")))
	      (if (and (common:file-exists? tconfig-file)
		       (file-read-access? tconfig-file))
		  (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
			(old-link-tree  (get-environment-variable "MT_LINKTREE")))
		    (if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
		    (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
		      (hash-table-set! *testconfigs* test-name newtcfg)
		      (if old-link-tree 
			  (setenv "MT_LINKTREE" old-link-tree)
			  (unsetenv "MT_LINKTREE"))
		      newtcfg))
		  (if (null? tal)
		      (begin
			(debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name)
			#f)
		      (loop (car tal)(cdr tal))))))))))

;; cannot move to dbmod until lazy-read-testconfig is unravelled.
;;
(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
  (if test-id 
      (let* ((test-dat      (db:get-test-info-by-id dbstruct run-id test-id)))
	(if test-dat
	    (let* ((test-rundir   (db:test-get-rundir       test-dat)) ;; ) ;; )
		   (test-name     (db:test-get-testname     test-dat))
		   (item-path     (db:test-get-item-path    test-dat))
		   (duration      (db:test-get-run_duration test-dat))
		   (comment       (db:test-get-comment      test-dat))
		   (event-time    (db:test-get-event_time   test-dat))
		   (tconfig       #f)
		   (state         (if newstate  newstate  (db:test-get-state  test-dat)))
		   (status        (if newstatus newstatus (db:test-get-status test-dat))))
	      ;; (mutex-lock! *triggers-mutex*)
              (handle-exceptions
               exn
               (begin
                 (debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus
                                    "\n   error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn
                                    "\n   test-rundir="test-rundir
                                    "\n   test-name="test-name
                                    "\n   item-path="item-path
                                    "\n   state="state
                                    "\n   status="status
                                    "\n")
                 (print-call-chain (current-error-port))
                 #f)
               (if (and test-name
                        test-rundir)   ;; #f means no dir set yet
                   ;; (common:file-exists? test-rundir)
                   ;; (directory? test-rundir))
                   (call-with-environment-variables
                    (list (cons "MT_TEST_NAME"    (or test-name "no such test"))
                          (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet"))
                          (cons "MT_ITEMPATH"     (or item-path "")))
                    (lambda ()
                      (if (directory-exists? test-rundir)
                          (push-directory test-rundir)
                          (push-directory *toppath*))
                      (set! tconfig (mt:lazy-read-test-config test-name))
                      (for-each (lambda (trigger)
                                  (let* ((munged-trigger (string-translate trigger "/ " "--"))
					(logname        (conc "last-trigger-" munged-trigger ".log")))
                                    ;; first any triggers from the testconfig
                                    (let ((cmd  (configf:lookup tconfig "triggers" trigger)))
                                      (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status)))
                                    ;; next any triggers from megatest.config
                                    (let ((cmd  (configf:lookup *configdat* "triggers" trigger)))
                                      (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status)))))
                                (list
                                 (conc state "/" status)
                                 (conc state "/")
                                 (conc "/" status)))
		     (pop-directory))
                    )))
	      ;; (mutex-unlock! *triggers-mutex*)
	      )))))