Megatest

	      (tests:summarize-test run-id test-id)) ;; don't force - just update if no
	    (mutex-unlock! m)
	    (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " 
			 work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
	    (if (not (vector-ref exit-info 1))
		(exit 4)))))))

(define (launch:read-cached-config)
  (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs
      (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
			       (get-environment-variable "MT_TARGET")   "/"
			       (get-environment-variable "MT_RUNNAME")  "/"
			       ".megatest.cfg")))
	(if (file-exists? alistconfig)
	    (list (configf:read-alist alistconfig)
		  (get-environment-variable "MT_RUN_AREA_HOME"))
	    #f))
      #f)) 

(define (launch:read-megatest-config toppath)
  (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))))
    (if runname (setenv "MT_RUNNAME" runname))
    (find-and-read-config 
     (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
     environ-patt: "env-override"
     given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
     pathenvvar: "MT_RUN_AREA_HOME")))

;; set up the very basics needed for doing anything here.
(define (launch:setup-for-run area-dat #!key (force #f))
  ;; would set values for KEYS in the environment here for better support of env-override but 
  ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to 
  ;; pass on that idea for now
  ;; special case
  (let ((configdat (megatest:area-configdat area-dat)))
    (if (or force (not (hash-table? configdat)))  ;; no need to re-open on every call










	(let* ((newconfiginfo (or (launch:read-cached-config) ;; no config cached - give up


				  (launch:read-megatest-config (megatest:area-path area-dat))))
	       (configdat     (car  newconfiginfo))

	       (toppath       (cadr newconfiginfo)))

	  (megatest:area-configinfo-set! area-dat newconfiginfo)
	  (megatest:area-configdat-set!  area-dat configdat)
	  (megatest:area-path-set!       area-dat toppath)
	  (let* ((tmptransport (configf:lookup configdat "server" "transport"))
		 (transport    (if tmptransport (string->symbol tmptransport) 'http)))
	    (if (member transport '(http rpc nmsg))
		(megatest:area-transport-set! area-dat transport)
		(begin
		  (debug:print 0 "ERROR: Unrecognised transport " transport)
		  (exit))))
	  (let ((linktree (configf:lookup configdat "setup" "linktree"))) ;; link tree is critical
	    (if linktree
		(if (not (file-exists? linktree))
		    (begin
		      (handle-exceptions
		       exn
		       (begin
			 (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
			 (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
			 (exit 1))
		       (create-directory linktree #t))))
		(begin
		  (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
		  (exit 1)))
	    (if linktree
		(let ((dbdir (conc linktree "/.db")))
		  (handle-exceptions
		   exn
		   (begin
		     (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
		     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
		   (if (not (directory-exists? dbdir))(create-directory dbdir)))
		  (setenv "MT_LINKTREE" linktree))
		(begin
		  (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
		  (exit 1)))
	    (if (and toppath
		   (directory-exists? toppath))
	      (setenv "MT_RUN_AREA_HOME" toppath)
	      (begin
		(debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
		(exit 1))))

	  toppath))))

(define (launch:cache-config area-dat)
  ;; if we have a linktree and -runtests and -target and the directory exists dump the config
  ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
  (let ((configdat (megatest:area-configdat area-dat)))
    (if (and configdat 
	     (args:get-arg "-runtests"))
	(let* ((linktree (get-environment-variable "MT_LINKTREE"))
	       (target   (common:args-get-target))
	       (runname  (or (args:get-arg "-runname")
			     (args:get-arg ":runname")))
	       (fulldir  (conc linktree "/"
			       target "/"
			       runname)))
	  (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir)
	  (if (file-exists? linktree) ;; can't proceed without linktree
	      (begin
		(if (not (file-exists? fulldir))
		    (create-directory fulldir #t)) ;; need to protect with exception handler 
		(if (and target
			 runname
			 (file-exists? fulldir))
		    (let ((tmpfile  (conc fulldir "/.megatest.cfg." (current-seconds)))
			  (targfile (conc fulldir "/.megatest.cfg")))
		      (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
		      (configf:write-alist configdat tmpfile)
		      (system (conc "ln -sf " tmpfile " " targfile))
		      ))))))))

(define (get-best-disk confdat)
  (let* ((disks    (hash-table-ref/default confdat "disks" #f))
	 (minspace (let ((m (configf:lookup confdat "setup" "minspace")))
		     (string->number (or m "10000")))))
    (if disks 
	(let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb

;; 
;;  <linkdir> - <target> - <testname> [ - <itempath> ]
;; 
;; All log file links should be stored relative to the top of link path
;;  
;; <target> - <testname> [ - <itempath> ] 
;;
(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat area-dat #!key (remtries 2))
  (let* ((configdat (megatest:area-configdat area-dat))
	 (item-path (if (string? itemdat) itemdat (item-list->path itemdat))) ;; if pass in string - just use it
	 (runname   (if (string? run-info) ;; if we pass in a string as run-info use it as run-name.
			run-info
			(db:get-value-by-header (db:get-rows run-info)
						(db:get-header run-info)
						"runname")))
	 ;; convert back to db: from rdb: - this is always run at server end
	 (target   (string-intersperse (map cadr keyvals) "/"))

	 (not-iterated  (equal? "" item-path))

	 ;; all tests are found at <rundir>/test-base or <linkdir>/test-base
	 (testtop-base (conc target "/" runname "/" testname))
	 (test-base    (conc testtop-base (if not-iterated "" "/") item-path))

	 ;; nb// if itempath is not "" then it is prefixed with "/"
	 (toptest-path (conc disk-path "/" testtop-base))
	 (test-path    (conc disk-path "/" test-base))

	 ;; ensure this exists first as links to subtests must be created there
	 (linktree  (let ((rd (config-lookup configdat "setup" "linktree")))
		      (if rd rd (conc (megatest:area-path area-dat) "/runs"))))

	 (lnkbase   (conc linktree "/" target "/" runname))
	 (lnkpath   (conc lnkbase "/" testname))
	 (lnkpathf  (conc lnkpath (if not-iterated "" "/") item-path))
	 (lnktarget (conc lnkpath "/" item-path)))

    ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical

	   (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))

    (if (not (directory? test-path))
	(create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes

    (if (and test-src-path (directory? test-path))
	(begin
	  (let* ((ovrcmd (let ((cmd (config-lookup configdat "setup" "testcopycmd")))
			   (if cmd
			       ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
			       (string-substitute "TEST_TARG_PATH" test-path
						  (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
			       #f)))
		 (cmd    (if ovrcmd 
			     ovrcmd

;; 1. look though disks list for disk with most space
;; 2. create run dir on disk, path name is meaningful
;; 3. create link from run dir to megatest runs area 
;; 4. remotely run the test on allocated host
;;    - could be ssh to host from hosts table (update regularly with load)
;;    - could be netbatch
;;      (launch-test db (cadr status) test-conf))
(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params area-dat)
  (let ((toppath   (megatest:area-path      area-dat))
	(configdat (megatest:area-configdat area-dat)))
  (change-directory toppath)
  (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute"
   (list ;; (list "MT_TEST_RUN_DIR" work-area)
    (list "MT_RUN_AREA_HOME" toppath)
    (list "MT_TEST_NAME" test-name)
    ;; (list "MT_ITEM_INFO" (conc itemdat)) 
    (list "MT_RUNNAME"   runname)
    ;; (list "MT_TARGET"    mt_target)
    ))
  (let* ((useshell        (let ((ush (config-lookup configdat "jobtools"     "useshell")))
			    (if ush 
				(if (equal? ush "no") ;; must use "no" to NOT use shell
				    #f
				    ush)
				#t)))     ;; default is yes
	 (launcher        (config-lookup configdat "jobtools"     "launcher"))
	 (runscript       (config-lookup test-conf   "setup"        "runscript"))
	 (ezsteps         (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big
	 (diskspace       (config-lookup test-conf   "requirements" "diskspace"))
	 (memory          (config-lookup test-conf   "requirements" "memory"))
	 (hosts           (config-lookup configdat "jobtools"     "workhosts"))
	 (remote-megatest (config-lookup configdat "setup" "executable"))
	 (run-time-limit  (or (configf:lookup  test-conf   "requirements" "runtimelim")
			      (configf:lookup  configdat "setup" "runtimelim")))
	 ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to 
	 ;;                allow running from dashboard. Extract the path
	 ;;                from the called megatest and convert dashboard
	 ;;             	  or dboard to megatest
	 (local-megatest  (let* ((lm  (car (argv)))
				 (dir (pathname-directory lm))
				 (exe (pathname-strip-directory lm)))

    (if launcher (set! launcher (string-split launcher)))
    ;; set up the run work area for this test
    (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run
	     (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir
	(begin
	  (debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
	  (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record
    
    ;; prevent overlapping actions - set to LAUNCHED as early as possible
    ;;
    (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
    (rmt:roll-up-pass-fail-counts run-id test-name item-path "LAUNCHED")
    (set! diskpath (get-best-disk configdat))
    (if diskpath
	(let ((dat  (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat)))
	  (set! work-area (car dat))
	  (set! toptest-work-area (cadr dat))
	  (debug:print-info 2 "Using work area " work-area))
	(begin
	  (set! work-area (conc test-path "/tmp_run"))
	  (create-directory work-area #t)
	  (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run")))
    (set! cmdparms (base64:base64-encode 
		    (z3:encode-buffer 
		     (with-output-to-string
		       (lambda () ;; (list 'hosts     hosts)
			 (write (list (list 'testpath  test-path)
				      (list 'transport (conc (megatest:area-transport area-dat))) ;;; *transport-type*))
				      ;; (list 'serverinf *server-info*)
				      (list 'toppath   toppath)
				      (list 'work-area work-area)
				      (list 'test-name test-name) 
				      (list 'runscript runscript) 
				      (list 'run-id    run-id   )
				      (list 'test-id   test-id  )
				      ;; (list 'item-path item-path )
				      (list 'itemdat   itemdat  )
				      (list 'megatest  remote-megatest)
				      (list 'ezsteps   ezsteps) 
				      (list 'target    mt_target)
				      (list 'runtlim   (if run-time-limit (common:hms-string->seconds run-time-limit) #f))
				      (list 'env-ovrd  (hash-table-ref/default configdat "env-override" '())) 
				      (list 'set-vars  (if params (hash-table-ref/default params "-setvars" #f)))
				      (list 'runname   runname)
				      (list 'mt-bindir-path mt-bindir-path))))))))

    ;; clean out step records from previous run if they exist
    ;; (rmt:delete-test-step-records run-id test-id)
    (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir

      (set! fullcmd (append (list remote-megatest test-sig "-execute" cmdparms) debug-param (list (if useshell "&" ""))))))
    ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" "")))))
    (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm"))))
    (debug:print 1 "Launching " work-area)
    ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done
    (debug:print 4 "fullcmd: " fullcmd)
    (let* ((commonprevvals (alist->env-vars
			    (hash-table-ref/default configdat "env-override" '())))
	   (testprevvals   (alist->env-vars
			    (hash-table-ref/default test-conf "pre-launch-env-overrides" '())))
	   (miscprevvals   (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute"
			    (append (list (list "MT_TEST_RUN_DIR" work-area)
					  (list "MT_TEST_NAME" test-name)
					  (list "MT_ITEM_INFO" (conc itemdat)) 
					  (list "MT_RUNNAME"   runname)
					  (list "MT_TARGET"    mt_target)
					  (list "MT_ITEMPATH"  item-path)
					  )
				    itemdat)))
	   ;; Launchwait defaults to true, must override it to turn off wait
	   (launchwait     (if (equal? (configf:lookup configdat "setup" "launchwait") "no") #f #t))
	   (launch-results (apply (if launchwait
				      cmd-run-with-stderr->list
				      process-run)
				  (if useshell
				      (let ((cmdstr (string-intersperse fullcmd " ")))
					(if launchwait
					    cmdstr

            ;; NB// Is this still needed? Should be safe to go back to "exit" now?
            (process-signal (current-process-id) signal/kill)
            ))
      (alist->env-vars miscprevvals)
      (alist->env-vars testprevvals)
      (alist->env-vars commonprevvals)
      launch-results))
  (change-directory toppath))
  ;; added paren below after refactoring above routine. must have missed something?
  )