Overview
Comment: | Hacked to get vars working ok. NOT REENTRANT. Must rework :( |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | envhandling |
Files: | files | file ages | folders |
SHA1: |
0f355e808706759e60353e7505a815d3 |
User & Date: | matt on 2011-11-02 21:58:28 |
Other Links: | branch diff | manifest | tags |
Context
2011-11-02
| ||
21:59 | Merged from envhandling branch check-in: da715ac6ab user: matt tags: trunk, v1.32 | |
21:58 | Hacked to get vars working ok. NOT REENTRANT. Must rework :( Closed-Leaf check-in: 0f355e8087 user: matt tags: envhandling | |
18:09 | envvar handling is not reentrant. Need a better solution. Putting this stuff on a branch for now check-in: b71bf64192 user: mrwellan tags: envhandling | |
Changes
Modified configf.scm from [4590f7c875] to [ef264b880e].
︙ | ︙ | |||
88 89 90 91 92 93 94 | (if (null? res) "" (string-intersperse res " "))))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key val)) (loop (read-line inp) curr-section-name #f #f)) (loop (read-line inp) curr-section-name #f #f))) | | | > > > > | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | (if (null? res) "" (string-intersperse res " "))))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key val)) (loop (read-line inp) curr-section-name #f #f)) (loop (read-line inp) curr-section-name #f #f))) (key-val-pr ( x key val ) (let* ((alist (hash-table-ref/default res curr-section-name '())) (envar (and environ-patt (string-match (regexp environ-patt) curr-section-name))) (realval (if envar (config:eval-string-in-environment val) val))) (if envar (begin (debug:print 4 "INFO: read-config key=" key ", val=" val ", realval=" realval) (setenv key realval))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key realval)) (loop (read-line inp) curr-section-name key #f))) ;; if a continued line (cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (if var-flag ;; if set to a string then we have a continued var (let ((newval (conc |
︙ | ︙ |
Modified launch.scm from [7996f32f59] to [b3346272f9].
︙ | ︙ | |||
58 59 60 61 62 63 64 65 66 67 68 69 70 71 | (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)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (fullrunscript (if runscript (conc testpath "/" runscript) #f)) (db #f)) (debug:print 2 "Exectuing " test-name " on " (get-host-name)) (change-directory testpath) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) (debug:print 4 "varpairs: " varpairs) | > | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | (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)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (fullrunscript (if runscript (conc testpath "/" runscript) #f)) (db #f)) (debug:print 2 "Exectuing " test-name " on " (get-host-name)) (change-directory testpath) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) (debug:print 4 "varpairs: " varpairs) |
︙ | ︙ | |||
86 87 88 89 90 91 92 93 94 95 96 97 98 99 | (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db (set! db (open-db)) (change-directory work-area) (set-run-config-vars db run-id) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars db run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") | > | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db (set! db (open-db)) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory work-area) (set-run-config-vars db run-id) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars db run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") |
︙ | ︙ |
Modified runconfig.scm from [ddff02cb0f] to [12d1c1602d].
︙ | ︙ | |||
9 10 11 12 13 14 15 | (declare (uses common)) (include "common_records.scm") (define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f)) (let* ((keys (get-keys db)) (keyvals (get-key-vals db run-id)) | < | > > > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | (declare (uses common)) (include "common_records.scm") (define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f)) (let* ((keys (get-keys db)) (keyvals (get-key-vals db run-id)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")) (confdat (read-config fname #f #f environ-patt: environ-patt)) (whatfound (make-hash-table)) (sections (list "default" thekey))) (debug:print 4 "Using key=\"" thekey "\"") (for-each (lambda (key val) (setenv (vector-ref key 0) val)) keys keyvals) (for-each (lambda (section) (let ((section-dat (hash-table-ref/default confdat section #f))) (if section-dat (for-each (lambda (envvar) (hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1)) |
︙ | ︙ | |||
40 41 42 43 44 45 46 | (set! *already-seen-runconfig-info* #t))))) (define (set-run-config-vars db run-id) (let ((runconfigf (conc *toppath* "/runconfigs.config"))) (if (file-exists? runconfigf) (setup-env-defaults db runconfigf run-id #f environ-patt: ".*") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)))) | | | 44 45 46 47 48 49 50 51 | (set! *already-seen-runconfig-info* #t))))) (define (set-run-config-vars db run-id) (let ((runconfigf (conc *toppath* "/runconfigs.config"))) (if (file-exists? runconfigf) (setup-env-defaults db runconfigf run-id #f environ-patt: ".*") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)))) |
Modified runs.scm from [cf599e0423] to [5e902b8e73].
︙ | ︙ | |||
548 549 550 551 552 553 554 555 556 557 558 559 560 561 | (keyvallst (keys->vallist keys #t)) (run-id (register-run db keys)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config"))) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (file-exists? runconfigf) (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* environ-patt: ".*") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) (if (and (eq? *passnum* 0) (args:get-arg "-keepgoing")) (begin | > > | 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 | (keyvallst (keys->vallist keys #t)) (run-id (register-run db keys)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config"))) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* environ-patt: ".*") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) (if (and (eq? *passnum* 0) (args:get-arg "-keepgoing")) (begin |
︙ | ︙ | |||
588 589 590 591 592 593 594 | ;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc (define (run-one-test db run-id test-name keyvallst) (debug:print 1 "Launching test " test-name) ;; All these vars might be referenced by the testconfig file reader (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" (args:get-arg ":runname")) | > | > | 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 | ;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc (define (run-one-test db run-id test-name keyvallst) (debug:print 1 "Launching test " test-name) ;; All these vars might be referenced by the testconfig file reader (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" (args:get-arg ":runname")) ;; (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory *toppath*) (let* ((test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ... (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) (test-conf (if testexists (read-config test-configf #f #t) (make-hash-table))) (waiton (let ((w (config-lookup test-conf "requirements" "waiton"))) (if (string? w)(string-split w)'()))) |
︙ | ︙ | |||
828 829 830 831 832 833 834 835 836 837 838 839 840 841 | (keyvallst (keys:target->keyval keys target)) (run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (test-names '()) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '())) (if (file-exists? runconfigf) (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) | > > | 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 | (keyvallst (keys:target->keyval keys target)) (run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (test-names '()) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '())) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) |
︙ | ︙ |