@@ -30,10 +30,13 @@ (declare (unit launch)) (declare (uses subrun)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) + +(declare (uses commonmod)) +(import commonmod) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -735,11 +738,11 @@ (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) - (list "MT_TESTSUITENAME" (common:get-area-name)))) + (list "MT_TESTSUITENAME" (common:get-area-name *alldat*)))) ;;(bb-check-path msg: "launch:execute post block 3") (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;;(bb-check-path msg: "launch:execute post block 4") ;; (change-directory top-path) @@ -1024,28 +1027,54 @@ (define (launch:setup-body #!key (force-reread #f) (areapath #f)) (if (and (eq? *configstatus* 'fulldata) *toppath* (not force-reread)) ;; no need to reprocess *toppath* ;; return toppath - (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting. We do not have *configdat*. Bootstrapping problem here. + (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks + ;; *configdat* for + ;; use-cache setting. + ;; We do not have + ;; *configdat*. + ;; Bootstrapping problem + ;; here. (toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath (target (common:args-get-target)) (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) - ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ... + ;; checking for null cachefiles should not be necessary, + ;; I was seeing error car of '(), might be a chicken bug + ;; or a red herring ... (mtcachef (if (null? cachefiles) #f - (car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) + (car cachefiles))) ;; (and cachedir (conc + ;; cachedir "/" + ;; ".megatest.cfg-" + ;; megatest-version + ;; "-" + ;; megatest-fossil-hash))) (rccachef (if (null? cachefiles) #f - (cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) - ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?))))) - (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource - ;;(BB> "launch:setup-body -- cachefiles="cachefiles) + (cdr cachefiles)))) ;; (and cachedir + ;; (conc cachedir "/" + ;; ".runconfigs.cfg-" + ;; megatest-version + ;; "-" + ;; megatest-fossil-hash))) + ;; (cancreate (and + ;; cachedir + ;; (common:file-exists? + ;; cachedir)(file-write-access? + ;; cachedir) (not + ;; (common:in-running-test?))))) + (set! *toppath* toppath) ;; This is needed when we are running + ;; as a test using CMDINFO as a + ;; datasource (BB> "launch:setup-body + ;; -- cachefiles="cachefiles) (cond - ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME + ;; if mtcachef exists just read it, however we need to assume + ;; toppath is available in $MT_RUN_AREA_HOME ((and (not force-reread) mtcachef rccachef use-cache (get-environment-variable "MT_RUN_AREA_HOME") (common:file-exists? mtcachef) @@ -1056,12 +1085,13 @@ (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*) - ;; there are no existing cached configs, do full reads of the configs and cache them - ;; we have all the info needed to fully process runconfigs and megatest.config + ;; there are no existing cached configs, do full reads of the + ;; configs and cache them we have all the info needed to + ;; fully process runconfigs and megatest.config ((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it? mtcachef rccachef) ;; BB- why are we doing this without asking if caching is desired? ;;(BB> "launch:setup-body -- cond branch 2") (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect @@ -1150,11 +1180,17 @@ "/runconfigs.config") *runconfigdat* #t sections: sections))) (set! *configinfo* cfgdat) (set! *configdat* (car cfgdat)) (set! *runconfigdat* rdat) (set! *toppath* toppath) - (set! *configstatus* 'partial)) + (set! *configstatus* 'partial) + ;; set up as many vars in *alldat* as possible here + (alldat-areapath-set! *alldat* toppath) + (alldat-log-port-set! *alldat* *default-log-port*) + (alldat-mtconfig-set! *alldat* *configdat*) + + ) (begin (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") (exit 2)))))) ;; COND ends here. @@ -1185,11 +1221,11 @@ ))) (if (and *toppath* (directory-exists? *toppath*)) (begin (setenv "MT_RUN_AREA_HOME" *toppath*) - (setenv "MT_TESTSUITENAME" (common:get-area-name))) + (setenv "MT_TESTSUITENAME" (common:get-area-name *alldat*))) (begin (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") (set! *toppath* #f) ;; force it to be false so we return #f #f)) @@ -1540,11 +1576,11 @@ ((dboard) "../megatest") ((mtest) "../megatest") ((dashboard) "megatest") (else exe))))) (launcher (common:get-launcher *configdat* test-name item-path)) ;; (config-lookup *configdat* "jobtools" "launcher")) - (test-sig (conc (common:get-area-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path + (test-sig (conc (common:get-area-name *alldat*) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) @@ -1593,11 +1629,11 @@ (car hhdat) #f))) (list 'serverurl (if *runremote* (remote-server-url *runremote*) #f)) ;; - (list 'areaname (common:get-area-name)) + (list 'areaname (common:get-area-name *alldat*)) (list 'toppath *toppath*) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id )