Megatest

;; Run a shell command and return the output as a string
(define (shell cmd)
  (let* ((output (cmd-run->list cmd))
	 (res    (car output))
	 (status (cadr output)))
    (if (equal? status 0)
	(let ((outres (string-intersperse 
		       res
		       "\n")))
	  (debug:print 4 "INFO: shell result:\n" outres)
	  outres)
	(begin
	  (with-output-to-port (current-error-port)
	    (print "ERROR: " cmd " returned bad exit code " status))
	  ""))))

;; Lookup a value in runconfigs based on -reqtarg or -target
(define (runconfigs-get config var)

	       (configf:section-rx ( x section-name ) (loop (configf:read-line inp res) section-name #f #f))
	       (configf:key-sys-pr ( x key cmd      ) (if allow-system
							  (let ((alist (hash-table-ref/default res curr-section-name '()))
								(val-proc (lambda ()
									    (let* ((cmdres  (cmd-run->list cmd))
										   (status  (cadr cmdres))
										   (res     (car  cmdres)))
									      (debug:print 4 "INFO: " inl "\n => " (string-intersperse res "\n"))
									      (if (not (eq? status 0))
										  (begin
										    (debug:print 0 "ERROR: problem with " inl ", return code " status
												 " output: " cmdres)
										    (exit 1)))
									      (if (null? res)
										  ""
										  (string-intersperse res " "))))))
							    (hash-table-set! res curr-section-name 
									     (config:assoc-safe-add alist
												    key 

	 (cmdparms   #f)
	 (fullcmd    #f) ;; (define a (with-output-to-string (lambda ()(write x))))
	 (mt-bindir-path #f)
	 (item-path (item-list->path itemdat))
	 (testinfo   (rdb:get-test-info db run-id test-name item-path))
	 (test-id    (db:test-get-id testinfo))
	 (debug-param (if (args:get-arg "-debug")(list "-debug" (args:get-arg "-debug")) '())))
    (if hosts (set! hosts (string-split hosts)))
    ;; set the megatest to be called on the remote host
    (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
    (set! mt-bindir-path (pathname-directory remote-megatest))
    (if launcher (set! launcher (string-split launcher)))
    ;; set up the run work area for this test
    (set! diskpath (get-best-disk *configdat*))
    (if diskpath
	(let ((dat  (create-work-area db run-id test-path diskpath test-name itemdat)))
	  (set! work-area (car dat))
	  (set! toptest-work-area (cadr dat))
	  (debug:print 2 "INFO: 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 (with-output-to-string
					   (lambda () ;; (list 'hosts     hosts)
					     (write (list (list 'testpath  test-path)
							  (list 'work-area work-area)
							  (list 'test-name test-name) 
							  (list 'runscript runscript) 
							  (list 'run-id    run-id   )
							  (list 'test-id   test-id  )
							  (list 'itemdat   itemdat  )
							  (list 'megatest  remote-megatest)
							  (list 'ezsteps   ezsteps) 
							  (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))))))) ;; (string-intersperse keyvallst " "))))
    ;; clean out step records from previous run if they exist
    (db:delete-test-step-records db run-id test-name itemdat)
    (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
    (cond
     ((and launcher hosts) ;; must be using ssh hostname
      (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param)))
     ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
     (launcher
      (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms) debug-param)))
     ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms))))
     (else
      (if (not useshell)(debug:print 0 "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section"))
      (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 megatest for test " test-name " in " work-area" ...")
    (test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
    ;; 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" '())))