Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1779,10 +1779,28 @@ "# export " "export ") key "=" delim (mungeval val) delim))) envvars))))) + +(define (common:get-param-mapping #!key (flavor #f)) + "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches" + (let ((default '(("tag-expr" . "-tagexpr") + ("mode-patt" . "-modepatt") + ("run-name" . "-runname") + ("contour" . "-contour") + ("mode-patt" . "-mode-patt") + + ("test-patt" . "-testpatt") + ("msg" . "-m") + ("new" . "-set-state-status")))) + (if (eq? flavor 'switch) + (map (lambda (x) + (cons (string->symbol (conc "-" (car x)) (cdr x)))) + default) + default))) + ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) ;; a value of #f means "unset this var" ;; (define (alist->env-vars lst) @@ -1797,18 +1815,16 @@ (safe-setenv var (->string val)) (unsetenv var)))) lst) res) '())) + ;; clear vars matching pattern, run proc, set vars back ;; if proc is a string run that string as a command with ;; system. ;; - - - (define (common:without-vars proc . var-patts) (let ((vars (make-hash-table))) (for-each (lambda (vardat) ;; each env var (for-each @@ -1827,60 +1843,10 @@ vars (lambda (var val) (setenv var val))) vars)) -(define (common:get-param-mapping #!key (flavor #f)) - "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches" - (let ((default '(("tag-expr" . "-tagexpr") - ("mode-patt" . "-modepatt") - ("run-name" . "-runname") - ("contour" . "-contour") - ("mode-patt" . "-mode-patt") - - ("test-patt" . "-testpatt") - ("msg" . "-m") - ("new" . "-set-state-status")))) - (if (eq? flavor 'switch) - (map (lambda (x) - (cons (string->symbol (conc "-" (car x)) (cdr x)))) - default) - default))) - -(define (common:sub-megatest-selector-switches test-run-dir) - (let* ((switch-def-alist (common:get-param-mapping flavor: 'config))) - (subrunfile (conc test-run-dir "/testconfig.subrun" )) - (subrundata (with-input-from-file subrunfile read)) - (subrunconfig (configf:alist->config subrundata))) - ;; note - get precmd from subrun section - ;; apply to submegatest commands - - (apply append - (filter-map (lambda (item) - (let ((config-key (car item)) - (switch (cdr item)) - (val (configf:lookup subrunconfig switch))) - (if val - (list switch val) - #f))) - switch-def-alist)))) - -(define (common:sub-megatest-run test-run-dir switches #!key (logfile #f)) - (let* ((real-logfile (or logfile (conc (test-run-dir) "/subrun-" - (string-substitute "[/*]" "_" (string-intersperse switches "^"))"-" - (number->string (current-seconds)) ".log"))) - (selector-switches (common:sub-megatest-selector-switches test-run-dir)) - (cmd-list `("megatest" ,@selector-switches ,@switches "-log" ,real-logfile)) - ) - (call-with-environment-variables - (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) - (lambda () - (common:without-vars proc "^MT_.*") - - )))) - - (define (common:run-a-command cmd #!key (with-vars #f)) (let* ((pre-cmd (dtests:get-pre-command)) (post-cmd (dtests:get-post-command)) (fullcmd (if (or pre-cmd post-cmd) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -293,11 +293,12 @@ (loop (+ i 1))) ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if (or ezsteps subrun) - (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? + (let* ((test-run-dir (tests:get-test-path-from-environment)) + (testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic ;; ezstep names need a full re-eval here. (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) (ezstepslst (if (hash-table? testconfig) (hash-table-ref/default testconfig "ezsteps" '()) @@ -321,11 +322,12 @@ ;; 4. fix runname ;; 5. fix testpatt or calculate it from contour ;; 6. launch the run ;; 7. roll up the run result and or roll up the logpro processed result (if (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested - (configf:write-alist testconfig "testconfig.subrun") ;; BB: created here + (subrun:initialize-toprun-test testconfig test-run-dir) + (let* ((runarea (let ((ra (configf:lookup testconfig "subrun" "run-area"))) (if ra ;; when runarea is not set we default to *toppath*. However ra ;; we need to force the setting in the testconfig so it will (begin ;; be preserved in the testconfig.subrun file (configf:set-section-var testconfig "subrun" "runarea" *toppath*) ADDED subrun.scm Index: subrun.scm ================================================================== --- /dev/null +++ subrun.scm @@ -0,0 +1,92 @@ + + +(define (subrun:initialize-toprun-test test-run-dir testconfig) + (let ((ra (configf:lookup testconfig "subrun" "run-area"))) + (when (not ra) ;; when runarea is not set we default to *toppath*. However + ;; we need to force the setting in the testconfig so it will + ;; be preserved in the testconfig.subrun file + (configf:set-section-var testconfig "subrun" "runarea" *toppath*) + ) + + (configf:write-alist testconfig "testconfig.subrun") + ) + + +(define (subrun:launch ) + + + + ) + +;; set state/status of test item +;; fork off megatest +;; set state/status of test item +;; + + +(define (subrun:selector+log-switches test-run-dir log-prefix) + (let* ((switch-def-alist (common:get-param-mapping flavor: 'config)) + (subrunfile (conc test-run-dir "/testconfig.subrun" )) + (subrundata (with-input-from-file subrunfile read)) + (subrunconfig (configf:alist->config subrundata)) + (run-area (configf:lookup subrunconfig "subrun" "run-area")) + (defvals `(("-runname" . ,(get-environment-variable "MT_RUNNAME")) + ("-target" . ,(get-environment-variable "MT_TARGET")))) + (switch-alist (apply + append + (filter-map (lambda (item) + (let ((config-key (car item)) + (switch (cdr item)) + (defval (alist-ref defvals switch equal?)) + (val (or (configf:lookup subrunconfig switch) + defval))) + (if val + (list switch val) + #f))) + switch-def-alist))) + (target (alist-ref switch-alist "-target" equal?)) + (runname (alist-ref switch-alist "-runname" equal?)) + (testpatt (alist-ref switch-alist "-testpatt" equal?)) + (mode-patt (alist-ref switch-alist "-modepatt" equal?)) + (tag-expr (alist-ref switch-alist "-tagexpr" equal?)) + (compact-stem (string-substitute "[/*]" "_" + (conc + (or target "NO-TARGET") + "-" + (or runname "NO-RUNNAME") + "-" (or testpatt mode-patt tag-expr "NO-TESTPATT")))) + (logfile (conc + test-run-dir "/" + (or log-prefix "") + (if log-prefix "-" "") + compact-stem + ".log"))) + ;; note - get precmd from subrun section + ;; apply to submegatest commands + + (conc + " -start-dir " run-area " " + + (string-intersperse + (apply append + (map (lambda (x) (list (car x) (cdr x))) switch-def-alist)) + " ") + "-log " logfile))) + + +(define (subrun:exec-sub-megatest test-run-dir switches #!key (logfile #f)) + (let* ((real-logfile (or logfile (conc (test-run-dir) "/subrun-" + (string-substitute "[/*]" "_" (string-intersperse switches "^"))"-" + (number->string (current-seconds)) ".log"))) + (selector-switches (common:sub-megatest-selector-switches test-run-dir)) + (cmd-list `("megatest" ,@selector-switches ,@switches "-log" ,real-logfile)) + ) + (call-with-environment-variables + (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) + (lambda () + (common:without-vars proc "^MT_.*") + + )))) + + +