Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -556,13 +556,14 @@
(let ((res (assoc key lst)))
(if res (cadr res)(if (null? default) #f (car default)))))
(define (common:get-testsuite-name)
(or (configf:lookup *configdat* "setup" "testsuite" )
- (if (string? *toppath* )
+ (getenv "MT_TESTSUITE_NAME")
+ (if *toppath*
(pathname-file *toppath*)
- (pathname-file (current-directory)))))
+ #f))) ;; (pathname-file (current-directory)))))
(define (common:get-db-tmp-area)
(if *db-cache-path*
*db-cache-path*
(if *toppath*
@@ -950,11 +951,12 @@
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
(if *configdat*
- (configf:lookup *configdat* "setup" "linktree"))))
+ (configf:lookup *configdat* "setup" "linktree")
+ #f)))
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -421,10 +421,11 @@
(serverurl (assoc/default 'serverurl cmdinfo))
(homehost (assoc/default 'homehost cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(target (assoc/default 'target cmdinfo))
+ (areaname (assoc/default 'areaname cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(env-ovrd (assoc/default 'env-ovrd cmdinfo))
(set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar
(runname (assoc/default 'runname cmdinfo))
(megatest (assoc/default 'megatest cmdinfo))
@@ -441,10 +442,17 @@
(if (and (file-exists? fulln)
(file-execute-access? fulln))
fulln
runscript))))) ;; assume it is on the path
) ;; (rollup-status 0)
+
+ ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
+ ;;
+ (setenv "MT_TESTSUITENAME" areaname)
+ (setenv "MT_RUN_AREA_HOME" top-path)
+ (set! *toppath* top-path)
+ (setenv "MT_TEST_RUN_DIR" work-area)
;; On NFS it can be slow and unreliable to get needed startup information.
;; i. Check if we are on the homehost, if so, proceed
;; ii. Check if host and port passed in via CMDINFO are valid and if
;; possible use them.
@@ -598,11 +606,11 @@
(list "MT_ITEM_INFO" (conc itemdat))
(list "MT_ITEMPATH" item-path)
(list "MT_RUNNAME" runname)
(list "MT_MEGATEST" megatest)
(list "MT_TARGET" target)
- (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree"))
+ (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(list "MT_TESTSUITENAME" (common:get-testsuite-name))))
(if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
;; (change-directory top-path)
;; Can setup as client for server mode now
@@ -760,148 +768,145 @@
(let ((res (launch:setup-body force: force areapath: areapath)))
(mutex-unlock! *launch-setup-mutex*)
res)))
(define (launch:setup-body #!key (force #f) (areapath #f))
- (let* ((use-cache (common:use-cache?))
- (toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
- (runname (common:args-get-runname))
- (target (common:args-get-target))
- (linktree (common:get-linktree))
- (sections (if target (list "default" target) #f)) ;; for runconfigs
- (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config
- (rundir (if (and runname target linktree)(conc linktree "/" target "/" runname) #f))
- (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
- (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))
+ (if (and (eq? *configstatus* 'fulldata) *toppath*) ;; no need to reprocess
+ *toppath* ;; return toppath
+ (let* ((use-cache (common:use-cache?))
+ (toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
+ (runname (common:args-get-runname))
+ (target (common:args-get-target))
+ (linktree (common:get-linktree))
+ (sections (if target (list "default" target) #f)) ;; for runconfigs
+ (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config
+ (rundir (if (and runname target linktree)(conc linktree "/" target "/" runname) #f))
+ (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
+ (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))
(cancreate (and rundir (common:file-exists? rundir)(file-write-access? rundir)))
- (cxt (hash-table-ref/default *contexts* toppath #f)))
-
- ;; create our cxt for this area if it doesn't already exist
- (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt)))
-
- ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef)
- (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
- (cond
- ;; data was read and cached and available in *configstatus*, toppath has already been set
- ((eq? *configstatus* 'fulldata)
- *toppath*)
- ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
+ (cxt (hash-table-ref/default *contexts* toppath #f)))
+
+ ;; create our cxt for this area if it doesn't already exist
+ (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt)))
+
+ ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef)
+ (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
+ (cond
+ ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
((and mtcachef (common:file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME") use-cache)
- (set! *configdat* (configf:read-alist mtcachef))
- (set! *runconfigdat* (configf:read-alist rccachef))
- (set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME")))
- (set! *configstatus* 'fulldata)
- (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
- *toppath*)
- ;; we have all the info needed to fully process runconfigs and megatest.config
- (mtcachef
- (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
- mtconfig
- environ-patt: "env-override"
- given-toppath: toppath
- pathenvvar: "MT_RUN_AREA_HOME"))
- (first-rundat (let ((toppath (if toppath
- toppath
- (car first-pass))))
- (read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now.
- (conc (if (string? toppath)
- toppath
- (get-environment-variable "MT_RUN_AREA_HOME"))
- "/runconfigs.config")
- *runconfigdat* #t
- sections: sections))))
- (set! *runconfigdat* first-rundat)
- (if first-pass ;;
- (begin
- (set! *configdat* (car first-pass))
- (set! *configinfo* first-pass)
- (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
- (set! toppath *toppath*)
- (if (not *toppath*)
- (begin
- (debug:print-error 0 *default-log-port* "you are not in a megatest area!")
- (exit 1)))
- (setenv "MT_RUN_AREA_HOME" *toppath*)
- ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
- (let* ((keys (rmt:get-keys))
- (key-vals (keys:target->keyval keys target))
- (linktree (or (getenv "MT_LINKTREE")
- (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
- (second-pass (find-and-read-config
- mtconfig
- environ-patt: "env-override"
- given-toppath: toppath
- pathenvvar: "MT_RUN_AREA_HOME"))
- (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
- (for-each (lambda (kt)
- (setenv (car kt) (cadr kt)))
- key-vals)
- (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
- sections: sections))))
- (if cancreate (configf:write-alist runconfigdat rccachef))
- (set! *runconfigdat* runconfigdat)
- (if cancreate (configf:write-alist *configdat* mtcachef))
- (if cancreate (set! *configstatus* 'fulldata))))
- ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table
- (set! *configdat* (make-hash-table))
- )))
- ;; else read what you can and set the flag accordingly
- (else
- (let* ((cfgdat (find-and-read-config
- (or (args:get-arg "-config") "megatest.config")
- environ-patt: "env-override"
- given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
- pathenvvar: "MT_RUN_AREA_HOME")))
- (if cfgdat
- (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
- (rdat (read-config (conc toppath ;; convert this to use runconfig:read!
- "/runconfigs.config") *runconfigdat* #t sections: sections)))
- (set! *configinfo* cfgdat)
- (set! *configdat* (car cfgdat))
- (set! *runconfigdat* rdat)
- (set! *toppath* toppath)
- (set! *configstatus* 'partial))
- (begin
- (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.")
- (exit 2))))))
- ;; additional house keeping
- (let* ((linktree (or (getenv "MT_LINKTREE")
- (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))))
- (if linktree
- (begin
+ (set! *configdat* (configf:read-alist mtcachef))
+ (set! *runconfigdat* (configf:read-alist rccachef))
+ (set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME")))
+ (set! *configstatus* 'fulldata)
+ (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
+ *toppath*)
+ ;; we have all the info needed to fully process runconfigs and megatest.config
+ (mtcachef
+ (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
+ mtconfig
+ environ-patt: "env-override"
+ given-toppath: toppath
+ pathenvvar: "MT_RUN_AREA_HOME"))
+ (first-rundat (let ((toppath (if toppath
+ toppath
+ (car first-pass))))
+ (read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now.
+ (conc (if (string? toppath)
+ toppath
+ (get-environment-variable "MT_RUN_AREA_HOME"))
+ "/runconfigs.config")
+ *runconfigdat* #t
+ sections: sections))))
+ (set! *runconfigdat* first-rundat)
+ (if first-pass ;;
+ (begin
+ (set! *configdat* (car first-pass))
+ (set! *configinfo* first-pass)
+ (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
+ (set! toppath *toppath*)
+ (if (not *toppath*)
+ (begin
+ (debug:print-error 0 *default-log-port* "you are not in a megatest area!")
+ (exit 1)))
+ (setenv "MT_RUN_AREA_HOME" *toppath*)
+ ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
+ (let* ((keys (rmt:get-keys))
+ (key-vals (keys:target->keyval keys target))
+ (linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
+ (second-pass (find-and-read-config
+ mtconfig
+ environ-patt: "env-override"
+ given-toppath: toppath
+ pathenvvar: "MT_RUN_AREA_HOME"))
+ (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
+ (for-each (lambda (kt)
+ (setenv (car kt) (cadr kt)))
+ key-vals)
+ (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
+ sections: sections))))
+ (if cancreate (configf:write-alist runconfigdat rccachef))
+ (set! *runconfigdat* runconfigdat)
+ (if cancreate (configf:write-alist *configdat* mtcachef))
+ (if cancreate (set! *configstatus* 'fulldata))))
+ ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table
+ (set! *configdat* (make-hash-table))
+ )))
+ ;; else read what you can and set the flag accordingly
+ (else
+ (let* ((cfgdat (find-and-read-config
+ (or (args:get-arg "-config") "megatest.config")
+ environ-patt: "env-override"
+ given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
+ pathenvvar: "MT_RUN_AREA_HOME")))
+ (if cfgdat
+ (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
+ (rdat (read-config (conc toppath ;; convert this to use runconfig:read!
+ "/runconfigs.config") *runconfigdat* #t sections: sections)))
+ (set! *configinfo* cfgdat)
+ (set! *configdat* (car cfgdat))
+ (set! *runconfigdat* rdat)
+ (set! *toppath* toppath)
+ (set! *configstatus* 'partial))
+ (begin
+ (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.")
+ (exit 2))))))
+ ;; additional house keeping
+ (let* ((linktree (common:get-linktree)))
+ (if linktree
+ (begin
(if (not (common:file-exists? linktree))
- (begin
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "Something went wrong when trying to create linktree dir at " linktree)
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (exit 1))
- (create-directory linktree #t))))
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "Something went wrong when trying to create link to linktree at " *toppath*)
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)))
- (let ((tlink (conc *toppath* "/lt")))
- (if (not (file-exists? tlink))
- (create-symbolic-link linktree tlink)))))
- (begin
- (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config")
- )))
- (if (and *toppath*
- (directory-exists? *toppath*))
- (begin
- (setenv "MT_RUN_AREA_HOME" *toppath*)
- (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)))
- (begin
- (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")
- ;;(exit 1)
- (set! *toppath* #f) ;; force it to be false so we return #f
- #f
- ))
- *toppath*))
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "Something went wrong when trying to create linktree dir at " linktree)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (exit 1))
+ (create-directory linktree #t))))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "Something went wrong when trying to create link to linktree at " *toppath*)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)))
+ (let ((tlink (conc *toppath* "/lt")))
+ (if (not (file-exists? tlink))
+ (create-symbolic-link linktree tlink)))))
+ (begin
+ (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config")
+ )))
+ (if (and *toppath*
+ (directory-exists? *toppath*))
+ (begin
+ (setenv "MT_RUN_AREA_HOME" *toppath*)
+ (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)))
+ (begin
+ (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")
+ ;;(exit 1)
+ (set! *toppath* #f) ;; force it to be false so we return #f
+ #f
+ ))
+ *toppath*)))
(define (get-best-disk confdat testconfig)
(let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
(hash-table-ref/default confdat "disks" #f)))
(minspace (let ((m (configf:lookup confdat "setup" "minspace")))
@@ -1208,11 +1213,12 @@
(if hhdat
(car hhdat)
#f)))
(list 'serverurl (if *runremote*
(remote-server-url *runremote*)
- #f)) ;;
+ #f)) ;;
+ (list 'areaname (common:get-testsuite-name))
(list 'toppath *toppath*)
(list 'work-area work-area)
(list 'test-name test-name)
(list 'runscript runscript)
(list 'run-id run-id )
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -290,19 +290,10 @@
(thread-sleep! 5)
(loop (server:check-if-running areapath)))))))
(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.
-(define (server:dotserver-age-seconds areapath)
- (let ((server-file (conc areapath "/.server")))
- (begin
- (handle-exceptions
- exn
- #f
- (- (current-seconds)
- (file-modification-time server-file))))))
-
;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;;
(define (server:check-if-running areapath)
(let* ((servers (server:get-best (server:get-list areapath))))
(if (null? servers)